|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 22400 (0x5780)
Types: TextFile
Names: »SPSKEMA.PAS«
└─⟦a1337913c⟧ Bits:30002679 PGM1 - indeholder forskellige undervisningsprogrammer
└─ ⟦this⟧ »SPSKEMA.PAS«
program sp_skema;
const maxsp=30;
maxvalg=20;
maxskema=500;
maxmaske=10;
op=@5;venstre=@19;hoejre=@4;ned=@24;return=@13;esc=@27;
back=@8@8@8@8@8@8@8@8@8@8; (* 10 skridt tilbage *)
feltpos : array(.1..maxsp,1..2.) of 1..70 =
( (10,2),(10,4),(10,6),(10,8),(10,10),
(10,12),(10,14),(10,16),(10,18),(10,20),
(30,2),(30,4),(30,6),(30,8),(30,10),
(30,12),(30,14),(30,16),(30,18),(30,20),
(50,2),(50,4),(50,6),(50,8),(50,10),
(50,12),(50,14),(50,16),(50,18),(50,20));
type svartype = array(.1..maxsp.) of 0..maxvalg;
skematype = record
nr: integer;
svar: svartype;
end;
masketype = record
sp : 1..maxsp;
maske : set of 0..maxvalg;
end;
var skema :skematype;
mulighed :svartype;
fil :text;
disk :file of skematype;
filnavn :string(.12.);
navn :string(.8.);
startet,maskeflag :boolean;
sv :char;
i,antalsp,antal_ind :integer;
skemastak :array(.1..maxskema.) of skematype;
s :array(.1..maxsp,0..maxvalg.) of integer;
sum :array(.1..maxsp.) of integer;
k :array(.0..maxvalg,0..maxvalg.) of integer;
si :array(.1..maxmaske.) of masketype;
antal_masker :0..maxmaske;
procedure forklaring;
begin
write(clrhom);
writeln(' Dette program kan benyttes til behandling af spørgeskemaer.');
writeln('Spørgeskemaet kan indeholde op til 30 forskellige spørgsmål.');
writeln('Hvert spørgsmål kan indeholde op til 20 svarmuligheder. Disse ');
writeln('skal kunne tillægges en talværdi mellem 1 og 20. Et spørgsmål,');
writeln('der ikke er besvaret indkodes med svaret 0.');
writeln('Ved indkodningen af svarene skal hvert skema have et nummer.');
writeln('Dette nummer bliver ikke benyttet af programmet i den nuværende');
writeln('udgave, men det kan dog benyttes til kontrol af de indtastede ');
writeln('skemaer-evt kan det sættes til 0.');
writeln;
writeln('Ved programstart vises en menu, hvoraf de forskellige muligheder');
writeln('fremgår. De indtastede data gemmes efter indtastningen på en ');
writeln('fil, hvorfra de kan hentes. Dette skal ALTID gøres inden den ');
writeln('endelige optælling og behandling foretages.');
writeln('Ved optællingen kan der defineres nogle specielle krav, der ');
writeln('skal være opfyldt for at skemaet indgår i optællingen.');
writeln('Disse krav kaldes masker og denne maskefunktion kan tændes ');
writeln('eller slukkes efter behov.');
writeln;
writeln('De spørgsmål programmet stiller og som kun kræver et bogstav');
writeln('som svar kræver ikke brug af <RETURN>-knappen.');
write(' ',rvson,'tast <RETURN> ',rvsoff);
readln;
end;
function input_tal : integer;
var x,p : integer;
ch : char;
tal_string : string(.8.);
begin
repeat
tal_string:='';
read(kbd,ch);
while ch<>return do begin
tal_string:=tal_string+ch;
write(ch);
read(kbd,ch);
end;
val(tal_string,x,p);
if p<>0 then write(chr(7),'??') ;
until p=0;
input_tal:=x;
end;
function pct(x,y :real):real;
begin
if y=0 then pct:=0 else pct:=x/y*100;
end;
function maske_kontrol(skema:skematype):boolean;
var i,spm : integer;
ok : boolean;
begin
if maskeflag and (antal_masker>0) then begin
i:=0;
repeat
i:=i+1;
spm:=si(.i.).sp;
ok:=skema.svar(.spm.) in si(.i.).maske;
until ( not ok ) or (i>=antal_masker);
maske_kontrol:=ok;
end
else
maske_kontrol:=true;
end;
procedure gotofelt(nr:integer);
var x,y :integer;
begin
x:=feltpos(.nr,1.);
y:=feltpos(.nr,2.);
gotoxy(x,y);
end;
procedure laes_disk; (* fastlægger antal_ind og skema_stak *)
begin
reset(disk);read(disk,skema);
antal_ind:=0;
while (not eof(disk)) and (antal_ind<maxskema) do begin
antal_ind:=antal_ind+1;
read(disk,skemastak(.antal_ind.));
end;
close(disk);
if antal_ind>=maxskema then begin
writeln('Der er maksimalt antal skemaer.');
write(' Tast <RETURN> ');
readln;
end;
end;
procedure tekstbilled(skema:skematype);
(**************************************************************************)
(* Der udskrives et tekstbilled, der indeholder oplysninger om indholdet *)
(* af skema. *)
(**************************************************************************)
var i,tal :integer;
begin
write(clrhom);
for i:=1 to antalsp do begin
gotofelt(i);
tal:=skema.svar(.i.);
write(back,'Sp. ',i:2,' ',rvson,tal:2,rvsoff);
end;
gotoxy(5,22);
write('Skriv det rigtige svar - Flyt med pilene - Afslut med <ESC>');
gotoxy(0,0);
write('Skema nr:',skema.nr:4);
end;
procedure laesfelt(var tast:char;var oktal:boolean;var tal :integer;
nr:integer);
(************************************************************************)
(* tast retunere den sidste tast, der er rørt. *)
(* oktal er sand, hvis tal er et tal, der kan bruges. *)
(* nr angiver i hvilket felt, der læses. *)
(************************************************************************)
var talstring : string(.2.);
x,p : integer;
slut,ok : boolean;
begin
repeat
talstring:='';gotofelt(nr);slut:=false;
repeat
read(kbd,tast);
case tast of
'0'..'9': begin
if len(talstring)=0 then write(' ',@8@8);
talstring:=talstring+tast;
write(tast);end;
op,ned,venstre,
hoejre,return : begin
slut:=true;
if len(talstring)>0 then begin
val(talstring,x,p);
ok:=p=0;
if ok then ok:=(x>=0) and (x<=mulighed(.nr.));
oktal:=ok;
gotofelt(nr);
write(rvson,x:2,rvsoff);
gotoxy(50,0);
if not oktal then begin
write(chr(7),rvson,'Tal uden for området!!',rvsoff);
end else write(clreol);
end else
oktal:=false;
end;
esc : begin
oktal:=false;
slut:=true;
end;
otherwise write(chr(7));
end;
until slut;
until (tast=esc) or oktal or (len(talstring)=0) ;
if oktal then tal:=x;
end;
procedure ret_skema(var skema :skematype);
var ok : boolean;
tal,felt : integer;
ch :char;
begin
tekstbilled(skema);
felt:=1;
repeat
laesfelt(ch,ok,tal,felt);
if ok then skema.svar(.felt.):=tal;
case ch of
op : begin felt:=felt-1;if felt=0 then felt:=antalsp; end;
venstre: if (felt>10) and (antalsp>10) then felt:=felt-10;
hoejre : if (antalsp>10) and (felt<=antalsp-10) then felt:=felt+10;
ned,return : begin felt:=felt+1;
if felt>antalsp then felt:=1;
end;
end;
gotofelt(felt);
until ch=esc;
end;
procedure gl_unders;
(**********************************************************************)
(* ved udgang kendes antalsp og mulighed samt filnavn eller også er *)
(* startet = FALSE *)
(**********************************************************************)
var fejl :integer;
begin
writeln(clrhom);startet:=false;
antal_ind:=0;
repeat
repeat
write('Hvad hedder undersøgelsen? (max 8 tegn, STOP standser.) ');
readln(navn);
until len(navn)>0;
fejl:=1;
if not ( (navn='STOP') or (navn='stop')) then begin
filnavn:=navn+'.sps';
(*$I-*) assign(disk,filnavn);reset(disk);(*$I+*)
fejl:=iores;
if fejl<>0 then writeln(rvson,'filen findes ikke!!',rvsoff);
end;
until (fejl=0) or (navn='STOP') or (navn='stop');
if fejl=0 then begin
read(disk,skema);
with skema do begin
antalsp:=nr;
mulighed:=svar;
end;
close(disk);
startet:=true;
end;
if (navn='STOP') or (navn='stop') then navn:='';
end; (* of gl_unders *)
procedure ny_unders;
(**********************************************************************)
(* ved udgang kendes antalsp og mulighed samt filnavn eller også er *)
(* startet = FALSE *)
(**********************************************************************)
var fejl,i : integer;
begin
writeln(clrhom); fejl:=0;startet:=false;antal_ind:=0;
repeat
repeat
write('Hvad skal undersøgelsen hedde? (max 8 tegn , STOP standser.) ');
readln(navn);
until len(navn)>0;
if not ((navn='STOP') or (navn='stop')) then begin
filnavn:=navn+'.sps';
(*$I-*) assign(disk,filnavn);reset(disk);(*$I+*)
fejl:=iores;
if fejl=0 then begin
writeln(rvson,'filen findes allerede!!',rvsoff);
close(disk);
end;
end;
until (fejl<>0) or ((navn='STOP') or (navn='stop'));
if not ((navn='STOP') or (navn='stop')) then begin
writeln;writeln;writeln;
repeat
write('Hvor mange spørgsmål er der ? (max ',maxsp,') ');
readln(antalsp);
until (0<antalsp) and (antalsp<=maxsp);
for i:=1 to antalsp do begin
repeat
write('Antal svarmuligheder i spørgsmål ',i,' : ');
readln(mulighed(.i.));
until (mulighed(.i.)>0) and (mulighed(.i.)<=maxvalg);
end;
with skema do begin
nr:=antalsp;
svar:=mulighed;
end;
rewrite(disk);
write(disk,skema);
close(disk);
startet:=true;
end
else
navn:='';
end;
procedure indtastning;
var snr,i : integer;
sv : char;
nulskema : skematype;
begin
nulskema.nr:=0;
for i:=1 to antalsp do nulskema.svar(.i.):=0;
write(clrhom);
antal_ind:=0;
repeat
skema:=nulskema;
gotoxy(0,0);write('Skema nr ? : ');snr:=input_tal;
skema.nr:=snr;
ret_skema(skema);
gotoxy(0,22);write(clreol,'Skal skema ',snr,' gemmes? (j/n) ');
repeat read(kbd,sv); until sv in (.'J','j','N','n'.);
if sv in (.'J','j'.) then begin
antal_ind:=antal_ind+1;
if antal_ind <= maxskema then
skemastak(.antal_ind.):=skema
else
writeln('Der kan ikke gemmes flere skemaer!!');
end else begin
write('Skema IKKE gemt - Flere skemaer? (j/n) ');
repeat read(kbd,sv); until sv in (.'J','j','N','n'.);
end;
until (sv in (.'N','n'.));
gotoxy(0,22);write(clreol,'......Et øjeblik og du kan gå videre.....');
reset(disk);seek(disk,length(disk));
for i:=1 to antal_ind do write(disk,skemastak(.i.));
close(disk);
end;
procedure for_udskriv(i :integer);
var j : integer;
begin
writeln(fil,'Optælling af ':20,antal_ind,' skemaer giver :');
writeln(fil);
write(fil,'Fordeling i spørgsmål ',i:4);
if maskeflag then
writeln(fil,' Der er benyttet masker!')
else
writeln(fil);
writeln(fil);
writeln(fil,'Svar antal ':15,' % ':12);
writeln(fil,'▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀');
for j:=1 to mulighed(.i.) do
writeln(fil,j:4,s(.i,j.):8,pct(s(.i,j.),sum(.i.)):15:1);
writeln(fil,'▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀▶88◀');
writeln(fil,' Besvaret ialt ',sum(.i.):12);
writeln(fil,' Ubesvarede ',s(.i,0.):12);
writeln(fil);
end;
procedure optaelling;
var ssum,i,j : integer;
ch,alle : char;
begin
writeln(clrhom,' ':25,'Svarfordeling laves!');
fill(s,size(s),0);
(* optæl *)
for i:=1 to antal_ind do begin
skema:=skemastak(.i.);
if maske_kontrol(skema) then
for j:=1 to antalsp do s(.j,skema.svar(.j.).):=s(.j,skema.svar(.j.).)+1;
end;
(* find søjlesummer *)
for i:=1 to antalsp do begin
ssum:=0;
for j:=1 to mulighed(.i.) do ssum:=ssum+s(.i,j.);
sum(.i.):=ssum;
end;
(*klar til udskrift *)
write('Ønskes udskrift på skærm eller printer ? (s/p) ');
repeat read(kbd,ch) until ch in (.'P','p','S','s'.);writeln(ch);
if ch in (.'P','p'.) then
assign(fil,'LST:')
else
assign(fil,'CON:');
rewrite(fil);
(* Hvilke tabeller skal udskrives?? *)
write('Udskrift af enkelte eller af alle tabeller ? (e/a) ');
repeat read(kbd,alle) until alle in (.'E','e','A','a'.);writeln(alle);
if alle in (.'A','a'.) then begin
for i:=1 to antalsp do begin
for_udskriv(i);
if ch in (.'S','s'.) then begin
gotoxy(0,24);write('tast <RETURN>');readln;write(clrhom);end
else
writeln(fil,chr(10),chr(10),chr(10));
end;
end else begin
repeat
write(clrhom,'Angiv tabelnummer. -1 standser. ');
i:=input_tal;
writeln;
if (i>0) and (i<=antalsp) then begin
for_udskriv(i);
if ch in (.'S','s'.) then begin
gotoxy(0,24);write('tast <RETURN>');readln;write(clrhom);
end;
end;
until i<=0 ;
end;
close(fil);
end;
procedure krydstabel;
var ch :char;
vandret,lodret, i,j : integer;
ssum : array(.1..maxvalg.) of integer;
streg : string(.79.);
relativ : boolean;
begin
streg:='';
for i:=1 to 79 do streg:=streg+'▶88◀';
repeat
writeln(clrhom,' Der kan nu laves krydstabeller. ');
write('Angiv første spørgsmål (vandret i tabellen).((højst 15)) ');
repeat
vandret:=input_tal;
until (vandret>0) and (vandret<=antalsp);
writeln;
write('Angiv nu andet spørgsmål. ');
repeat lodret:=input_tal until (lodret>0) and (lodret<=antalsp);
writeln;
write('Skal det være absolutte tal eller i % af søjleantal (a/p). ');
repeat read(kbd,ch) until ch in (.'A','a','P','p'.);writeln(ch);
relativ:= ch in (.'P','p'.);
(* klar til optælling *)
fill(k,size(k),0);
for i:=1 to antal_ind do
if maske_kontrol(skemastak(.i.)) then
k(.skemastak(.i.).svar(.lodret.),skemastak(.i.).svar(.vandret.).):=
k(.skemastak(.i.).svar(.lodret.),skemastak(.i.).svar(.vandret.).)+1;
fill(ssum,size(ssum),0);
for i:=1 to mulighed(.vandret.) do
for j:=1 to mulighed(.lodret.) do ssum(.i.):=ssum(.i.)+k(.j,i.);
(* summen i søjlerne er fundet og udskriften kan begynde *)
write('Ønskes udskrift på skærm eller printer? (s/p) ');
repeat read(kbd,ch) until ch in (.'S','s','P','p'.);writeln(ch);
if ch in (.'P','p'.) then
assign(fil,'LST:')
else
assign(fil,'CON:');
rewrite(fil);
if relativ then writeln(fil,'Krydstabel i % af søjleantal. ':30)
else writeln(fil,'Krydstabel i antal. ':25);
writeln(fil);writeln(fil,' Optalte skemaer :',antal_ind:4);
if maskeflag then
writeln(fil,' Der er benyttet masker!')
else
writeln(fil);
write(fil,lodret:2,'▶89◀',vandret:2,':');
for i:=1 to mulighed(.vandret.) do write(fil,i:4,' ');
if mulighed(.vandret.)<15 then writeln(fil);
writeln(fil,copy(streg,1,5+5*mulighed(.vandret.)));
for j:=1 to mulighed(.lodret.) do begin
write(fil,j:3,' ▶89◀');
for i:=1 to mulighed(.vandret.) do
if relativ then
write(fil,pct(k(.j,i.),ssum(.i.)):5:1)
else
write(fil,k(.j,i.):5);
if mulighed(.vandret.)<15 then writeln(fil);
end;
writeln(fil,copy(streg,1,5+5*mulighed(.vandret.)));
write(fil,'antal');
for i:=1 to mulighed(.vandret.) do write(fil,ssum(.i.):5);
if mulighed(.vandret.)<15 then writeln(fil);
writeln(fil);
write('tryk <RETURN>');readln;
write('Flere tabeller ? (j/n) ');
repeat read(kbd,sv) until sv in (.'J','j','N','n'.);
until sv in (.'N','n'.);
close(fil);
end;
procedure masker;
var maske_ind : masketype;
nr,msk : integer;
ch : char;
procedure hent_maske(spm:integer);
var i:integer;
begin
Writeln('Angiv de svar, der skal godkendes. (-1 afslutter) ');
writeln('Efter hver svarmulighed trykkes på <RETURN>.');
write('Svarmulighed --> ');
repeat
begin
i:=input_tal;
if not(i in (.-1,0,1..mulighed(.spm.).)) then write('??');
end
until i in (.-1,0,1..mulighed(.spm.).);
writeln;
maske_ind.maske:=(..);
while i>=0 do begin
maske_ind.maske:=maske_ind.maske+(.i.);
write('Svarmulighed --> ');
repeat
begin
i:=input_tal;
if not(i in (.-1,0,1..mulighed(.spm.).)) then write('??');
end
until i in (.-1,0,1..mulighed(.spm.).);
writeln;
end;
end; (* hent_maske *)
begin
repeat
writeln(clrhom,'Du kan nu vælge mellem følgende muligheder :');
writeln;
writeln(' N : Nye masker fremstilles.');
writeln(' V : Vis maskerne.');
writeln(' T : Tænd for maskefunktionen.');
writeln(' S : Sluk for maskefunktionen.');
writeln(' A : Afbryd denne programdel.');
writeln;
write(' Angiv det ønskede : ');
repeat read(kbd,ch) until ch in(.'N','n','T','t','S','s','A','a','V','v'.);
writeln(ch);
case ch of
'N','n' : begin
antal_masker:=0;
write('Angiv nummer på spørgsmålet (-1 standser) :');
repeat nr:=input_tal until nr in (.-1,1..antalsp.);
writeln;
while (nr>=1) and (antal_masker<maxmaske) do begin
maske_ind.sp:=nr;
hent_maske(nr);
if maske_ind.maske<>(..) then begin
antal_masker:=antal_masker+1;
si(.antal_masker.):=maske_ind;
end;
write(clrhom,'Angiv nummer på spørgsmålet (-1 standser) :');
repeat nr:=input_tal until nr in (.-1,1..antalsp.);
writeln;
end;
end;
'V','v' : begin
if antal_masker =0 then begin
writeln('Der er ikke defineret nogle masker.Tryk <RETURN>.');
readln;end
else begin
for msk:=1 to antal_masker do begin
write('Spørgsmål : ',si(.msk.).sp:3,' : ');
for nr:=0 to maxvalg do
if nr in si(.msk.).maske then write(nr:3,', ');
writeln;
end;
writeln;
writeln(' ',rvson,'Tryk <RETURN>.',rvsoff);
readln;
writeln;
end;
end;
'T','t' :begin
if antal_masker =0 then begin
writeln('Der er ikke defineret nogle masker. Tryk <RETURN>');
readln;
end;
maskeflag:= antal_masker>0;
end;
'S','s' : maskeflag:=false;
'A','a' : (* afslut *)
end;
until ch in (.'A','a'.);
end;
(* ---------------------HOVED PROGRAM ----------------*)
BEGIN
startet:=false;navn:='';maskeflag:=false;antal_masker:=0;antal_ind:=0;
repeat
write(clrhom);
write(rvson,navn:8,rvsoff,' ':17);
writeln(rvson,'SPØRGESKEMA - undersøgelse.',rvsoff);
writeln;
writeln(' Du har nu følgende muligheder at vælge mellem :');
writeln;
writeln(' 1 : Hente oplysninger om en gammel undersøgelse.');
writeln(' 2 : Foretage indlæsning af skemaer.');
writeln(' 3 : Indlæse alle skemaer fra disketten.');
writeln;
writeln(' 4 : Optælling af svarfordeling.');
writeln(' 5 : Lave krydstabeller.');
writeln(' 6 : Definere masker, der bestemmer optællingen.');
writeln;
writeln(' 7 : Starte en ny undersøgelse.');
writeln(' 8 : Standse.');
writeln(' 9 : Forklaring.');
writeln;
if maskeflag then begin
gotoxy(0,10);
write(rvson,'TÆNDT',rvsoff);
end;
gotoxy(0,17);
write(' ',rvson,'Tast det ønskede nummer.',rvsoff,' ');read(kbd,sv);
write(sv,' ');
case sv of
'7' : ny_unders;
'1' : gl_unders;
'2' : if startet then indtastning
else begin gotoxy(56,0);
write(rvson,chr(7),' brug først 1 eller 7',rvsoff);
gotoxy(56,1);Write('Tast <RETURN>');readln;
end;
'4' : if startet then optaelling
else begin gotoxy(56,0);
write(rvson,chr(7),' brug først 1 eller 7',rvsoff);
gotoxy(56,1);Write('Tast <RETURN>');readln;
end;
'5' : if startet then krydstabel
else begin gotoxy(56,0);
write(rvson,chr(7),' brug først 1 eller 7',rvsoff);
gotoxy(56,1);Write('Tast <RETURN>');readln;
end;
'6' : if startet then masker
else begin gotoxy(56,0);
write(rvson,chr(7),' brug først 1 eller 7',rvsoff);
gotoxy(56,1);Write('Tast <RETURN>');readln;
end;
'3' : if startet then begin writeln('Et øjeblik.');laes_disk;end
else begin gotoxy(56,0);
write(rvson,chr(7),' brug først 1 eller 7',rvsoff);
gotoxy(56,1);Write('Tast <RETURN>');readln;
end;
'8' :writeln(clrhom,'SLUT FOR DENNE GANG.');
'9' :forklaring;
otherwise write(chr(7))
END;
until sv='8';
end.
«eof»