home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fish 'n' More 2
/
fishmore-publicdomainlibraryvol.ii1991xetec.iso
/
dirs
/
cross_464.lzh
/
Cross
/
txt
/
Cross.mod
< prev
next >
Wrap
Text File
|
1991-03-09
|
18KB
|
750 lines
(***************************************************************************
:Program. Cross
:Author. Jürgen Weinelt
:Address. Zur Kanzel 1, D-8783 Hammelburg, Germany
:Version. V3.3
:Copyright. Freeware; copy it, but don't sell it!
:Language. Modula-II
:Translator. M2Amiga V3.32d
:Imports. CPCDosIO
:Imports. CPCError
:Imports. CPCGads
:Imports. CPCGlobal
:Imports. CPCPrint
:Imports. CPCRequesters
:Imports. CPCShowAll
:Imports. CPCSleep
:Imports. FileReq
:Contents. Program to create crossword puzzles.
:Contents. Features Intuition interface, filerequesters, and a special
:Contents. message data file to allow easy translation into any
:Contents. (human) language without changing the source code.
:History. V3.2 08-jan-91 first major release of M2 version on AMOK
:History. V3.3 06-feb-91 PAL/NTSC support added
**************************************************************************)
MODULE Cross;
FROM Arguments
IMPORT NumArgs,GetArg;
FROM Arts
IMPORT TermProcedure,Assert,Terminate,CurrentLevel;
FROM ASCII
IMPORT nul;
FROM Conversions
IMPORT ValToStr;
FROM CPCDosIO
IMPORT Value,ReadWords,LoadData,SaveData,ReadMsg,PrintCross,PrintSolution,
InitCPCDosIO,msgmode;
FROM CPCError
IMPORT myAssert;
FROM CPCGads
IMPORT ShowCommands,AllGadsOff;
FROM CPCGlobal
IMPORT string,lstring,stringlen,lstringlen,rastport,viewport,msg,maxmsg,
switch,search,show,screen,window,stat,column,field,yoff,blankC,
wordfield,puzzlewordfield,text,kwr,words,hori,vert,xmax,ymax,
maxgrid,topaz;
FROM CPCPrint
IMPORT Cls,Print,PrintAtC,PrintAtS,ClrLine;
FROM CPCRequesters
IMPORT HoriOrVert,InputLine,YesOrNo;
FROM CPCShowAll
IMPORT CharPos,ShowAll;
FROM CPCSleep
IMPORT NormalPointer,SleepPointer;
FROM Graphics
IMPORT SetRGB4;
FROM InOut
IMPORT WriteLn,WriteString,WriteInt;
FROM IntuiIO
IMPORT OpenScreen,CloseScreen,GetViewPort,OpenWindow,CloseWindow,
WindowRastPort,GetMessage,ReadMessage,GetGadgetId,AddIntuiMsg,
ScreenRastPort,GetMouse,
WINDOW,SCREEN,GADGET,ScreenType,ScreenTypeSet,
IntuiMsg,IntuiMsgSet,WindowType,WindowTypeSet,MousPos;
IMPORT IntuiIO;
FROM Intuition
IMPORT CurrentTime,IntuitionBasePtr;
IMPORT Intuition;
FROM RandomNumber
IMPORT RND,PutSeed;
FROM Strings
IMPORT Copy,Compare,Length;
FROM Str
IMPORT CapString;
FROM SYSTEM
IMPORT ADR;
CONST
progtitle="Crossword Puzzle Creator V3.3 *** ©1991 by J.Weinelt";
spcs=" ";
limitbase=24;
lowerylimit=5;
(* upperylimit=35; !!! now VAR: PAL/NTSC support added 06-feb-91 !!! *)
(* defmsgline=27; ^^^ same as above ^^^ *)
defxsize=19;
defysize=19;
lowerxlimit=5;
upperxlimit=39;
TYPE
direction=(horizontal,vertical);
VAR
dir,dir0: direction;
w,progname,tmp: string;
loop,word,wlen,x,y,cmp,num: INTEGER;
xloop,yloop,x0,y0,w0,len0,outerloop: INTEGER;
val0,tempH,tempV: INTEGER;
doH,booldummy: BOOLEAN;
limit,dummy,narg,msgline: INTEGER;
sec,micro: LONGINT;
msgmd: msgmode;
underl,scrname,winname: lstring;
ibase: IntuitionBasePtr;
pal: BOOLEAN;
upperylimit,defmsgline: INTEGER;
PROCEDURE CoolDown;
BEGIN
IF (window#NIL) THEN
CloseWindow(window);
END;
IF (screen#NIL) THEN
CloseScreen(screen);
END;
END CoolDown;
PROCEDURE MakeString(b: INTEGER; c: CHAR; VAR a: ARRAY OF CHAR);
VAR loop: INTEGER;
BEGIN
FOR loop:=0 TO b-1 DO
a[loop]:=c;
END;
a[b]:=nul;
END MakeString;
PROCEDURE check(w: ARRAY OF CHAR): BOOLEAN;
VAR
f: BOOLEAN;
loop: INTEGER;
BEGIN
f:=FALSE;
FOR loop:=0 TO hori+vert DO
f:=f OR (Compare(kwr[loop],0,stringlen,w,FALSE)=0);
END;
RETURN f;
END check;
PROCEDURE testH(VAR w: ARRAY OF CHAR; x,y,len,rlen,ref: INTEGER): INTEGER;
VAR v,loop: INTEGER;
f: BOOLEAN;
BEGIN
IF (x+len<=xmax) AND (text[x-1,y]=nul) AND (text[x+len+1,y]=nul) THEN
f:=FALSE;
v:=0;
FOR loop:=x TO x+len DO
IF (w[loop-x]=text[loop,y]) THEN
v:=v+1;
(* if char matches AND there's a non-nul char before OR after *)
(* this position, then we better get out of here... to avoid *)
(* something like "life" being matched with "lifeforms"! *)
IF (text[loop-1,y]#nul) OR (text[loop+1,y]#nul) THEN
loop:=x+len+1;
f:=TRUE;
END;
ELSE
IF (text[loop,y-1]#nul) OR (text[loop,y+1]#nul) OR (text[loop,y]#nul) THEN
loop:=x+len+1;
f:=TRUE;
END;
END;
END;
IF (NOT f) THEN
IF (v>ref) OR
((v=ref) AND (ref>0) AND ((len>rlen) OR
((len=rlen) AND (RND(10)<2)))) THEN
RETURN v;
END;
END;
END;
RETURN -1;
END testH;
PROCEDURE testV(VAR w: ARRAY OF CHAR; x,y,len,rlen,ref: INTEGER): INTEGER;
VAR v,loop: INTEGER;
f: BOOLEAN;
BEGIN
IF (y+len<=ymax) AND (text[x,y-1]=nul) AND (text[x,y+len+1]=nul) THEN
f:=FALSE;
v:=0;
FOR loop:=y TO y+len DO
IF (w[loop-y]=text[x,loop]) THEN
v:=v+1;
(* if char matches AND there's a non-nul char before OR after *)
(* this position, then we better get out of here... to avoid *)
(* something like "life" being matched with "lifeforms"! *)
IF (text[x,loop-1]#nul) OR (text[x,loop+1]#nul) THEN
loop:=y+len+1;
f:=TRUE;
END;
ELSE
IF (text[x-1,loop]#nul) OR (text[x+1,loop]#nul) OR (text[x,loop]#nul) THEN
loop:=y+len+1;
f:=TRUE;
END;
END;
END;
IF (NOT f) THEN
IF (v>ref) OR
((v=ref) AND (ref>0) AND ((len>rlen) OR
((len=rlen) AND (RND(10)<2)))) THEN
RETURN v;
END;
END;
END;
RETURN -1;
END testV;
PROCEDURE Place(a: ARRAY OF CHAR; x,y,len: INTEGER; d: direction);
VAR
loop: INTEGER;
BEGIN
Copy(kwr[hori+vert],a,0,stringlen);
IF (d=horizontal) THEN
INC(hori);
FOR loop:=x+1 TO x+len+1 DO
text[loop,y+1]:=a[loop-x-1];
END;
ELSE
INC(vert);
FOR loop:=y+1 TO y+len+1 DO
text[x+1,loop]:=a[loop-y-1];
END;
END;
END Place;
PROCEDURE status;
VAR tmp: string;
dummy: BOOLEAN;
lx,ly: INTEGER;
cnt,net: LONGINT;
BEGIN
cnt:=0; net:=0;
FOR lx:=1 TO xmax DO
FOR ly:=1 TO ymax DO
IF (text[lx,ly]#nul) THEN
INC(cnt);
IF ((text[lx+1,ly]#nul) OR (text[lx-1,ly]#nul)) AND
((text[lx,ly+1]#nul) OR (text[lx,ly-1]#nul)) THEN
INC(net);
END;
END;
END;
END;
PrintAtS(stat-1,0,msg[26]);
ValToStr(limit,FALSE,tmp,10,2,"0",dummy);
Print(tmp,0);
PrintAtS(stat+Length(msg[26])+2,0,msg[27]);
ValToStr(hori,FALSE,tmp,10,2,"0",dummy);
Print(tmp,0);
PrintAtS(stat+Length(msg[26])+Length(msg[27])+5,0,msg[28]);
ValToStr(vert,FALSE,tmp,10,2,"0",dummy);
Print(tmp,0);
PrintAtS(stat-1,1,msg[29]);
ValToStr(((cnt*100) DIV (LONGINT(xmax*ymax))),FALSE,tmp,10,2,"0",dummy);
Print(tmp,0);
PrintAtS(stat+Length(msg[29])+2,1,msg[30]);
IF (hori+vert#0) THEN
ValToStr(((net*200) DIV (LONGINT(hori+vert))),FALSE,tmp,10,3,"0",dummy);
ELSE
tmp:="000";
END;
Print(tmp,0);
END status;
PROCEDURE AskCommand;
VAR cmd: CHAR;
dummy,length,x,y: INTEGER;
word: string;
dummyStr: ARRAY[0..1] OF CHAR;
imsg: IntuiMsg;
gadID: INTEGER;
BEGIN
imsg:=GetMessage(window);
IF (imsg=gadgetUp) THEN
gadID:=GetGadgetId(window);
CASE gadID OF
|1: IF (search=on) THEN
search:=off;
ELSE
search:=on;
END;
ShowCommands;
|2: AllGadsOff;
SleepPointer;
ClrLine(msgline);
IF (xmax>ymax) THEN
length:=xmax;
ELSE
length:=ymax;
END;
NormalPointer;
InputLine(word,msg[40],
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz",
length);
SleepPointer;
CapString(word);
IF Length(word)>0 THEN
IF (check(word)) THEN
ClrLine(msgline);
Print(msg[41],0);
ELSE
x:=1; y:=1;
ClrLine(msgline);
Print(msg[42],0);
AddIntuiMsg(window,IntuiMsgSet{mouseButtons});
NormalPointer;
REPEAT
REPEAT
imsg:=GetMessage(window);
UNTIL imsg=mouseButtons;
x:=GetMouse(window,curentX);
y:=GetMouse(window,curentY);
CharPos(x,y);
UNTIL (x>=0) AND (y>=0);
SleepPointer;
ClrLine(msgline);
NormalPointer;
IF HoriOrVert(msg[43]) THEN
IF (testH(word,x+1,y+1,Length(word)-1,0,-1)>=0) THEN
SleepPointer;
Place(word,x,y,Length(word)-1,horizontal);
ShowAll;
ClrLine(msgline);
ELSE
SleepPointer;
ClrLine(msgline);
Print(msg[44],0);
END;
ELSE
IF (testV(word,x+1,y+1,Length(word)-1,0,-1)>=0) THEN
Place(word,x,y,Length(word)-1,vertical);
ShowAll;
ClrLine(msgline);
ELSE
ClrLine(msgline);
Print(msg[44],0);
END;
END;
END;
END;
status;
ShowAll;
NormalPointer;
ShowCommands;
|3: AllGadsOff;
SleepPointer;
ClrLine(msgline);
Print(msg[46],0);
PrintCross;
ClrLine(msgline);
NormalPointer;
ShowCommands;
|4: AllGadsOff;
SleepPointer;
ClrLine(msgline);
Print(msg[47],0);
PrintSolution;
ClrLine(msgline);
NormalPointer;
ShowCommands;
|5: AllGadsOff;
SleepPointer;
LoadData;
Cls;
ShowAll;
status;
NormalPointer;
ShowCommands;
|6: AllGadsOff;
SleepPointer;
SaveData;
ClrLine(msgline);
NormalPointer;
ShowCommands;
|7: AllGadsOff;
SleepPointer;
num:=ReadWords(FALSE);
ClrLine(msgline);
status;
NormalPointer;
ShowCommands;
|8: ClrLine(msgline);
limit:=limitbase;
Print(msg[49],0);
status;
|0: AllGadsOff;
IF YesOrNo(msg[50]) THEN
WriteLn; WriteString(msg[51]); WriteLn; WriteLn;
Terminate(CurrentLevel());
END;
ShowCommands;
|ELSE (* NOP *)
END;
END;
END AskCommand;
BEGIN
TermProcedure(CoolDown);
scrname:=progtitle;
MakeString(Length(scrname),"-",underl);
narg:=NumArgs();
xmax:=-1;
ymax:=-1;
msgmd:=nonumbers;
ibase:=ADR(Intuition);
IF (ibase^.firstScreen#NIL) THEN
(* try to figure out if this is a PAL or NTSC machine: *)
(* look at the "height" field of first screen and hope there's any *)
(* significance to this value *)
IF ibase^.firstScreen^.height=256 THEN
(* this is pal resolution *)
upperylimit:=35;
defmsgline:=27;
pal:=TRUE;
ELSE
(* anything else means "not pal", i like being on the safe side *)
upperylimit:=25;
defmsgline:=20;
pal:=FALSE;
END;
ELSE
(* there's probably no use showing any error messages if there's no *)
(* screen present at all... i guess this will never be executed anyway *)
Terminate(CurrentLevel());
END;
FOR loop:=1 TO narg DO
GetArg(loop,tmp,dummy);
IF (tmp[0]="-") THEN
tmp[0]:="0";
CASE tmp[1] OF
|"x","X": tmp[1]:="0";
xmax:=Value(tmp);
IF ((xmax<lowerxlimit) OR (xmax>upperxlimit) OR (ODD(xmax+1))) THEN
xmax:=-1;
WriteString("Illegal value for XSIZE; assuming default value");
WriteLn;
END;
|"y","Y": tmp[1]:="0";
ymax:=Value(tmp);
IF ((ymax<lowerylimit) OR (ymax>upperylimit) OR (ODD(ymax+1))) THEN
ymax:=-1;
WriteString("Illegal value for YSIZE; assuming default value");
WriteLn;
END;
|"d","D": msgmd:=numbers;
|ELSE
END;
END;
END;
GetArg(0,progname,dummy);
IF (xmax=-1) THEN
xmax:=defxsize;
END;
IF (ymax=-1) THEN
ymax:=defysize;
END;
GetArg(1,tmp,dummy);
IF (tmp[0]="?") THEN
WriteLn;
WriteString(scrname); WriteLn;
WriteString(underl); WriteLn;
WriteString("Copyright ©1991 by Jürgen Weinelt, Zur Kanzel 1, D-8783 Hammelburg, Germany."); WriteLn; WriteLn;
WriteString("Please Note: CPC is FREEWARE; you may copy it, but do not sell it!"); WriteLn; WriteLn;
WriteString("Usage:"); WriteLn;
WriteString(progname); WriteString(" [?] [-xXSIZE] [-yYSIZE] [-d]"); WriteLn;
WriteString(" XSIZE: xsize in chars, ");
WriteInt(lowerxlimit,0); WriteString("<=x<=");
WriteInt(upperxlimit,0); WriteString(", default: ");
WriteInt(defxsize,0); WriteLn;
WriteString(" YSIZE: ysize in chars, ");
WriteInt(lowerylimit,0); WriteString("<=y<=");
WriteInt(upperylimit,0); WriteString(", default: ");
WriteInt(defysize,0); WriteLn;
WriteString(" -d: turn on message numbers (for word file debugging only!)");
WriteLn;
WriteString("Please note: XSIZE and YSIZE must be odd!"); WriteLn; WriteLn;
END;
IF (tmp[0]#"?") THEN
ReadMsg(msgmd);
IF pal THEN
screen:=OpenScreen(scrname,0,0,640,256,1,ScreenTypeSet{hires});
ELSE
screen:=OpenScreen(scrname,0,0,640,200,1,ScreenTypeSet{hires});
END;
Assert(screen#NIL,ADR(msg[52]));
viewport:=GetViewPort(screen);
SetRGB4(viewport, 0, 0, 0, 0); (* 0=black *)
SetRGB4(viewport, 1, 15,15,15); (* 1=white *)
SetRGB4(viewport,17, 6, 6, 6);
SetRGB4(viewport,18, 11,11,11);
SetRGB4(viewport,19, 15,15,15);
winname:=scrname;
IF pal THEN
window:=OpenWindow(winname,0,0,640,256,
WindowTypeSet{activWindow,backDrop,borderless},screen);
ELSE
window:=OpenWindow(winname,0,0,640,200,
WindowTypeSet{activWindow,backDrop,borderless},screen);
END;
Assert(window#NIL,ADR(msg[61]));
rastport:=WindowRastPort(window);
topaz:=rastport^.font;
AddIntuiMsg(window,IntuiMsgSet{gadgetUp});
InitCPCDosIO;
msgline:=defmsgline;
Print("",1);
Print(scrname,1);
Print(underl,2);
Print("©1991 by",1);
Print("Jürgen Weinelt",1);
Print("Zur Kanzel 1",1);
Print("D-8783 Hammelburg",1);
Print("Germany",2);
Print("Last changed: 06-Feb-91",2);
Print("Please note: CPC is FREEWARE; you may copy it, but do not sell it!",2);
Print("This program was created using M2Amiga and the IntuitionReport and",1);
Print("GraphicsReport support libraries. Thanks to A+L for these powerful tools.",2);
Print("Special thanks to the ARP people for their file requester.",2);
Print(msg[62],0);
SleepPointer;
num:=ReadWords(TRUE);
hori:=0; vert:=0;
CurrentTime(ADR(sec),ADR(micro));
PutSeed(sec);
IF (num>0) THEN
(* first word *)
cmp:=10;
IF (cmp>xmax-2) THEN
cmp:=xmax-2;
END;
REPEAT
word:=RND(num);
UNTIL (Length(words[word])>=cmp) AND (Length(words[word])<=xmax-2);
w:=words[word];
wlen:=Length(w)-1;
x:=1;
y:=1;
dir:=horizontal;
Place(w,x-1,y-1,wlen,dir);
words[word]:="";
(* second word *)
REPEAT
word:=RND(num);
UNTIL (Length(words[word])>=cmp) AND (Length(words[word])<=xmax-2);
w:=words[word];
wlen:=Length(w)-1;
x:=xmax-wlen;
y:=ymax;
dir:=horizontal;
Place(w,x-1,y-1,wlen,dir);
words[word]:="";
(* third word *)
cmp:=10;
IF (cmp>ymax-2) THEN
cmp:=ymax-2;
END;
REPEAT
word:=RND(num);
UNTIL (Length(words[word])>=cmp) AND (Length(words[word])<=ymax-2);
w:=words[word];
wlen:=Length(w)-1;
x:=xmax;
y:=1;
dir:=vertical;
Place(w,x-1,y-1,wlen,dir);
words[word]:="";
(* fourth word *)
REPEAT
word:=RND(num);
UNTIL (Length(words[word])>=cmp) AND (Length(words[word])<=ymax-2);
w:=words[word];
wlen:=Length(w)-1;
x:=1;
y:=ymax-wlen;
dir:=vertical;
Place(w,x-1,y-1,wlen,dir);
words[word]:="";
END;
Cls;
search:=off; show:=on;
ShowCommands;
limit:=limitbase;
status;
ShowAll;
NormalPointer;
(* main loop is "endless"; termination via Assert *)
(* in procedure AskCommand *)
LOOP
val0:=-1; len0:=0;
IF (show=off) THEN
show:=on;
ShowCommands;
END;
AskCommand;
IF (search=on) THEN
ShowCommands;
show:=off;
FOR outerloop:=0 TO num DO
word:=outerloop;
w:=words[word];
AskCommand;
IF (Length(w)>0) THEN
wlen:=Length(w)-1;
IF (wlen<limit) OR (wlen>limit+4) OR
(wlen+1<val0+val0) OR (wlen<=0) THEN
(* NOP *)
ELSIF (check(w)) THEN
words[word]:="";
ELSE
FOR xloop:=1 TO xmax DO
IF ((xloop MOD 2)=1) OR (limit<2) THEN
doH:=(xloop+wlen<=xmax);
FOR yloop:=1 TO ymax DO
IF ((yloop MOD 2)=1) OR (limit<2) THEN
tempH:=-1; tempV:=-1;
IF (doH) THEN
tempH:=testH(w,xloop,yloop,wlen,len0,val0);
END;
IF (yloop+wlen<=ymax) THEN
tempV:=testV(w,xloop,yloop,wlen,len0,val0);
END;
IF (tempH#-1) AND (tempH>=tempV) THEN
val0:=tempH; x0:=xloop; y0:=yloop;
w0:=word; dir0:=horizontal; len0:=wlen;
ClrLine(msgline);
Print(w,0);
ELSIF (tempV#-1) THEN
val0:=tempV; x0:=xloop; y0:=yloop;
w0:=word; dir0:=vertical; len0:=wlen;
ClrLine(msgline);
Print(w,0);
END;
END;
END;
END;
END;
END;
END;
END;
IF (val0>=1) THEN
Place(words[w0],x0-1,y0-1,Length(words[w0])-1,dir0);
ShowAll;
ClrLine(msgline);
Print(words[w0],0);
Print(msg[64],0);
words[w0]:="";
ELSE
IF (limit>1) THEN
limit:=limit-2;
ELSE
ClrLine(msgline);
Print(msg[65],0);
search:=off;
END;
END;
status;
ShowAll;
END;
END;
END;
END Cross.