Program Crossword; uses crt,dos,graph,mouse; const SPACE_SYMBOL = ' '; NOTEQ_SYMBOL = #255; type SetArray =array[1..100,1..100] of byte; BoolArray= array [1..100,1..100] of boolean; TWord = string[20]; TCW = array [1..50, 1..50] of Char; TGnezdo = record X, Y : Byte; Len : Byte; flHoriz : Boolean; end; kol_bukv=record first:longint; last:longint; end; bukvi=array [1..10,1..10] of char; Tarr_kol_bukv=array[1..29] of kol_bukv; TgnezdoArr=array [1..100] of Tgnezdo; var CW : TCW; Fwbase : Text; flg :boolean; UsedNum : integer; selected :BoolArray; len_x,len_y,q,len,w:integer; a :setarray; gnezdo :TgnezdoArr; Used : array [1..1000] of string[5]; b :Tarr_kol_bukv ; driver,mode,i,j,n,z,i1,j1:integer; old_mouse, cur_mouse:boolean; size_x,size_y:integer; c :byte; OKtoExit : boolean; Stack: Array[1..1000] of char; StackHead: word; Procedure Push(cc: char); Begin Inc(StackHead); Stack[StackHead] := cc; End; Function Pop: char; Begin Pop := Stack[StackHead]; Dec(StackHead); End; procedure circl; {zastavka } const gr:integer=vga; gd:integer=Vgahi; var x,y,r,i,j:integer; q:integer; begin Randomize; q:=0; repeat inc(q); x:=random(640); y:=random(480); for r:=0 to 30 +random(50) do begin setcolor(5); Circle(x,y,r); setcolor(0); circle(x+1,y+1,r); end; until q=10; setcolor(4); settextstyle(4,0,6); I:=110; j:=80 ; OutTextXY(60+i,50+j,'C' ); delay(10000); OutTextXY(90+i,70+j,'R' ); delay(10000); OutTextXY(120+i,90+j,'O' ); delay(10000); OutTextXY(150+i,110+j,'S' ); delay(10000); OutTextXY(180+i,130+j,'S' ); delay(10000); OutTextXY(210+i,150+j,'M' ); delay(10000); OutTextXY(240+i,170+j,'A' ); delay(10000); OutTextXY(270+i,190+j,'K' ); delay(10000); OutTextXY(300+i,210+j,'E' ); delay(10000); OutTextXY(330+i,220+j,'R' ); delay(10000); readln; end; procedure ResetMouse; begin old_mouse := false; cur_mouse := false; if initmouse then; showmouse; end; function GetMouseEvent: byte; begin cur_mouse := (buttonpressed = 1); if cur_mouse <> old_mouse then begin if cur_mouse then GetMouseEvent := 1 { mouse pressed once } else GetMouseEvent := 2; { mouse released } end else GetMouseEvent := 0; { Nothing changed } old_mouse := cur_mouse; end; procedure PrintCW(var CW : TCW; n:integer); var Cx, Cy : Byte; begin gotoxy(1,1); for Cx := 1 to n do begin for Cy := 1 to n do Write(CW[Cx, Cy]); WriteLn; end; end; procedure DrawCW(var CW : TCW; n:integer); var Cx, Cy : Byte; ss: string; begin for Cx := 1 to n do for Cy := 1 to n do begin ss := CW[cx,cy]; if ss = '0' then ss := ' '; OutTextXY((cy-1)*len_y+10,(cx-1)*len_x+10,ss); end; end; function GetMask(G : TGnezdo;CW_SIZE_X,CW_SIZE_y:integer) : TWord; var Ch : Byte; Result : TWord; begin Result := ''; if (G.X + G.Len-1 > CW_SIZE_X) and (G.Y + G.Len-1 > CW_SIZE_Y) then begin Result := NOTEQ_SYMBOL; Exit; end; for Ch := 1 to G.Len do if G.flHoriz then Result := Result + CW[G.X, G.Y + Ch-1] else Result := Result + CW[G.X + Ch-1, G.Y]; GetMask := Result; end; function IsMaskOk(Msk, Wrd : TWord) : Boolean; var Ch : Byte; begin if Length(Msk) = Length(Wrd) then IsMaskOk := TRUE else begin IsMaskOk := FALSE; Exit; end; for Ch := 1 to Length(Wrd) do if (Msk[Ch] <> SPACE_SYMBOL) and (Msk[Ch] <> Wrd[Ch]) then begin IsMaskOk := FALSE; {Break;} Exit; end; end; Function Already(Wrd: TWord): boolean; var i: word; begin For i:=1 to UsedNum do If Wrd = Used[i] then begin Already := true; Exit; end; Already := false; end; procedure SetWord(G : TGnezdo;Wrd : TWord); var Ch : Byte; begin Inc(UsedNum); Used[UsedNum] := Wrd; for Ch := 1 to G.Len do if G.flHoriz then begin Push(CW[G.X, G.Y + Ch-1]); CW[G.X, G.Y + Ch-1] := Wrd[Ch]; end else begin Push(CW[G.X + Ch-1, G.Y]); CW[G.X + Ch-1, G.Y] := Wrd[Ch]; end; end; procedure UnSetWord(G : TGnezdo); var Ch : Byte; begin { Dec(UsedNum);} for Ch := 1 to G.Len do if G.flHoriz then begin CW[G.X, G.Y + Ch-1] := Pop; end else begin CW[G.X + Ch-1, G.Y] := Pop; end; end; procedure OpenWordBase(FName : string); begin Assign(Fwbase, FName); Reset(Fwbase); end; procedure CloseWordBase; begin Close(Fwbase); end; function GetNextWord(l: byte) : TWord; var F : Text; s : string; begin While not EoF(Fwbase) do begin readln(Fwbase,s); If (not Already(s)) and (Length(s)=l) then begin GetNextWord := s; Exit; end; end; GetNextWord := '-1'; end; Function Arbeit(GNum : Byte; n:integer; var cw1:TCW): boolean; var Msk, Wrd : TWord; StartBasePosition, OldUsedNum : Word; flNoWord ,flag: Boolean; begin If GNum > q Then begin Arbeit := true; Exit; end; { GoToXY(1,14); Writeln('GNUM: ',GNum:5); } flag :=false; Msk := GetMask(Gnezdo[GNum],n,n); flNoWord := FALSE; OldUsedNum := UsedNum; repeat Reset(Fwbase); repeat Wrd := GetNextWord(Gnezdo[GNum].len); until IsMaskOk(Msk, Wrd) or (Wrd = '-1'); if Wrd <> '-1' then begin SetWord(Gnezdo[GNum], Wrd); {PrintCW(CW,n);} If Arbeit(GNum+1,n,cw) Then begin Arbeit := true; Exit; end else UnSetWord(Gnezdo[GNum]); end else begin Arbeit := false; UsedNum := OldUsedNum; Exit; end; until false; end; procedure Vivod(var cw1:TCW); begin if Arbeit(1,n,cw) then; cw:=cw; end; Procedure Get_gnezda(a:setarray;var gnezdo:TgnezdoArr;n:integer; var q:integer); var len:byte; {massive gnezd} k:integer; procedure DoHoriz; begin len:=0; inc(q); gnezdo[q].x:=i; gnezdo[q].y:=j; gnezdo[q].flhoriz:= true; k:=j; while a[i,k]<>0 do begin inc(k); inc(len); end; gnezdo[q].len:=len; end; procedure DoVert; begin len:=0; inc(q); gnezdo[q].x:=i; gnezdo[q].y:=j; gnezdo[q].flHoriz:= false; k:=i; while a[k,j]<>0 do begin inc(k); inc(len); end; gnezdo[q].len:=len; end; begin q:=0; for i:=1 to n do for j:=1 to n-1 do begin If (a[i, j] = 1) and (a[i, j+1] = 1) Then begin If (j=1) Then DoHoriz Else if (a[i, j-1] = 0) Then DoHoriz; end; end; for i:=1 to n-1 do for j:=1 to n do begin If (a[i, j] = 1) and (a[i+1, j] = 1) Then begin If (i=1) Then DoVert Else if (a[i-1, j] = 0) Then DoVert; end; end; end; {rekursiya} PROCEDURE SORT_GNEZD(var gnezdo:Tgnezdoarr; q:integer); var i,j:integer; gnezd:Tgnezdo; begin for i:=1 to q-1 do for j:=i to q do begin if (gnezdo[i].len < gnezdo[j].len) then begin gnezd:=gnezdo[i]; gnezdo[i]:=gnezdo[j]; gnezdo[j]:=gnezd; end; end; end; {risuem setku,zapolnyaem 2 massiva : logi4eskii i edini4nii} procedure setka ( n:integer;var selected:BoolArray; var a:SetArray); begin size_x:=n; size_y:=n; len_x:=479 div size_x; len_y:=479 div size_y; setcolor(red); for i:=1 to size_y do for j:=1 to size_x do {risuem setku iz pryamoygolnikov} begin rectangle((j-1)*len_x,(i-1)*len_y,j*len_x,i*len_y ); selected[i,j]:=false; end; for i:=1 to 10 do for j:=1 to 10 do a[i,j]:=0; end; {v zavisimosti ot istinnosti zapolnyaem massiv nulyamii i edinicami} Procedure Zapolnyaem( selected:Boolarray;n:integer; var a:setarray); var k:boolean; cc: char; begin for i:=1 to n do for j:=1 to n do begin selected[i,j]:=false; end; repeat {na4inaem proveryat bil li wel4ok miw'u} showmouse; z:=GetMouseEvent; {buttonpressed;} for i:=1 to size_y do for j:=1 to size_x do begin if (mousein((j-1)*len_x,(i-1)*len_y,j*len_x,i*len_y )) and (z=1) then begin hidemouse; selected[i,j]:=not selected[i,j]; if selected[i,j] then begin setfillstyle(solidfill,lightgray); end else setfillstyle(solidfill,getbkcolor); bar ((j-1)*len_x,(i-1)*len_y,j*len_x,i*len_y ); setcolor(red); rectangle((j-1)*len_x,(i-1)*len_y,j*len_x,i*len_y ); end; end; k:=keypressed; until k; While keypressed do cc:=readkey; for i:=1 to 10 do begin for j:=1 to 10 do begin if not selected[i,j] then begin a[i,j]:=0; end else begin a[i,j]:=1; end; end; end; end; procedure increm(i_start, j_start: integer; n: integer; value: integer; var a: setarray); begin a[i_start, j_start] := value; if (i_start > 1) and (a[i_start - 1, j_start] > value) then increm(i_start - 1, j_start, n, value + 1, a); if (i_start < n) and (a[i_start + 1, j_start] > value) then increm(i_start + 1, j_start, n, value + 1, a); if (j_start > 1) and (a[i_start, j_start - 1] > value) then increm(i_start, j_start - 1, n, value + 1, a); if (j_start < n) and (a[i_start, j_start + 1] > value) then increm(i_start, j_start + 1, n, value + 1, a); end; function Proverka(b:setarray;n:integer):boolean; var i,j:integer; q:integer; begin q:=0; for i := 1 to n do for j := 1 to n do if b[i, j] = 1 then inc(b[i, j], n*n); for i := 1 to n do for j := 1 to n do if b[i, j] = n*n + 1 then Increm(i, j, n, 2, b); for i := 1 to n do for j := 1 to n do if b[i, j] <> 0 then dec(b[i, j]); for i := 1 to n do for j := 1 to n do if b[i,j]=1 then inc(q); {if q>1 then proverka:=false else proverka:=true;} Proverka := (q <= 1); end; function Prov_po_4(a:setarray;n:integer) :boolean; begin for i:=1 to n do for j:=1 to n do begin if a[i,j]=1 then if (a[i+1,j]=1) and (a[i,j+1]=1) and (a[i+1,j+1]=1) then inc(q); end; {if q>0 then Prov_po_4:=false else Prov_po_4:=true;} Prov_po_4 := (q <= 0); end; Procedure MENU; begin setcolor(white); settextstyle(4,0,4); rectangle(490, 55,600, 90); rectangle(490,100,600,150); rectangle(490,160,600,210); outTextXY(500,55,'New'); outTextXY(500,105,'Make!'); outTextXY(500,165,'EXIT'); end; { ‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚‚} { Osnovnaya programma } begin Window(25,25,100,100); writeln('Input the size of the crossvord:') ; readln(n); driver:=detect; initgraph(driver,mode,''); circl; clearviewport; menu; ResetMouse; OKtoExit := False; Repeat c := 0; repeat If GetMouseEvent = 1 then begin if mousein (490, 55,600, 90) then c:=1; if mousein (490,100,600,150) then c:=2; if mousein (490,160,600,210) then c:=3; end; until c>0; {menu(lightgray);} case c of 1: begin setviewport(0,0,479,479,clipoff); clearviewport; setka(n,selected,a); zapolnyaem(selected,n,a); {if proverka(a,n) and prov_po_4(a,n) then flg:=true else flg:=false;} flg := true; for i:=1 to n do for j:=1 to n do if a[i,j]=1 then CW[i,j]:=' ' else CW[i,j]:='0'; Get_gnezda(a, gnezdo,n, q); SORT_GNEZD( gnezdo, q); end; 2: begin if flg then begin StackHead := 0; UsedNum := 0; settextstyle(2,0,2) ; outtextXY(500,290,'VSE V NORME :))'); OpenWordBase('dos.txt'); vivod(CW); DrawCw(cw,n); {OKtoExit := true;} end else begin settextstyle(2,0,2) ; outtextXY(500,290,'KOSY4OK"s!'); outtextXY(500,320,'GMITE NEW!'); end; end; 3 :begin outtextXY(490,300,'Bolwoe spasibo!'); OKtoExit := true; end; end; until OKtoExit; closegraph; end.