Program Stereogrammi_01;
Uses Crt;
Type
  screen = array [1..80,1..24] of char;
var
  image : screen;

Procedure SetColor (t,b:byte);
Begin
  TextColor(t);
  TextBackground(b)
End;

Procedure Writexy (x,y:byte;s:string);
begin
  gotoxy (x,y);
  write (s)
end;

Function Pull (Min,Max:byte):byte;
begin
  pull := min + random (Max-min+1)
end;

Procedure DrawImage (var scr:screen);
var
  x,y : byte;
begin
  for x := 1 to 80 do
    for y := 1 to 24 do
      writexy (x,y,scr[x,y])
end;

Procedure GetImage (var scr:screen);
var
  x,y    : byte;
  ch,car : char;
begin
  setcolor (yellow,red);
  writexy  (1,25,
            ' Space - Toggle brick on/off ³ '+chr(27)+chr(24)+chr(25)+chr(26)+' - Move cursor ³ <CR> - Process pattern     ');
  setcolor (white,black);
  drawimage (scr);
  x := 40;
  y := 12;
  drawimage (scr);
  gotoxy (x,y);
  repeat
    if keypressed then
      begin
        ch := readkey;
        case ch of
          #00 : begin
                  ch := readkey;
                  case ch of
                    #72 : begin if y> 1 then dec(y); gotoxy (x,y) end;
                    #77 : begin if x<80 then inc(x); gotoxy (x,y) end;
                    #80 : begin if y<24 then inc(y); gotoxy (x,y) end;
                    #75 : begin if x> 1 then dec(x); gotoxy (x,y) end;
                  end
                end;
          #32 : begin
                  if scr[x,y] = chr(32) then
                    car := 'Û'
                  else
                    car := ' ';
                  scr[x,y] := car;
                  writexy (x,y,car);
                  gotoxy (x,y)
                end
        end
      end
    until ch = #13;
end;

function findhole (var scr:screen;y:byte):byte;
var
  x:byte;
begin
  x := 1;
  while (x<=80) and not (scr[x,y]=' ') and not (scr[x,y]='Û') do
    inc(x);
  if x<=80 then
    findhole := x
  else
    findhole := 0
end;

Procedure Transform (var scr:screen);
var
  x,y,n : byte;
  ch    : char;
  tmp   : string[25];
  chk   : boolean;
begin
  setcolor (yellow,red);
  writexy (1,25,' Processing the pattern, please wait...                                        ');
  setcolor (lightcyan,black);
  for y := 1 to 24 do
    begin
      tmp := '';
      repeat
        x := findhole (scr,y);
        if x<>0 then
          begin
            repeat
              ch  := chr (pull (65,90));
              chk := true;
              for n := 1 to length(tmp) do
                chk := chk and (ch <> tmp[n])
            until chk;
            tmp := tmp + ch;
            repeat
              if (scr[x,y]=' ') or (scr[x,y]='Û') then
                begin
                  scr[x,y] := ch;
                  writexy (x,y,ch)
                end;
              if scr[x+10,y]='Û' then
                inc (x,9)
              else
                inc (x,10)
            until x>80
          end
      until x = 0
    end;
  setcolor (white,red);
  writexy (40,25,' Done! Press a key to continue...');
  ch := readkey;
end;

Procedure SaveImage (var scr:screen);
var
  x,y  : byte;
  ch   : char;
  dest : text;
  name : string[12];
  label skip;
begin
  setcolor (yellow,red);
  writexy (1,25,' Saving stereogram. Insert name (max 12 char.):                   (ESC to skip)');
  setcolor (white,red);
  gotoxy (49,25);
  name := 'noname.grm';
  writexy (49,25,name);
  repeat
    ch := readkey;
    case ord(ch) of
      46,65..90,97..122 : begin if length(name)<=12 then name := name + ch; writexy (49,25,name) end;
      8 : begin delete (name,length(name),1); writexy (49,25,name+' ') end;
      0 : ch := readkey;
    end
  until (ch=#13) or (ch=#27);
  if ch=#27 then
    goto skip;
  assign (dest,name);
  rewrite (dest);
  for y := 1 to 24 do
    begin
      for x := 1 to 80 do
        write (dest,scr[x,y]);
      write (dest,chr(13))
    end;
  close (dest);
  skip:
end;

var
  scr : screen;
  ch  : char;
Begin
  randomize;
  clrscr;
  setcolor  (white,blue);
  writexy   (1,1,'                          Stereogram   Generator   V1.0                         ');
  setcolor  (lightgreen,black);
  writexy   (5,5,'Coded by IlCorvo during Halloween''s night...');
  writexy   (5,10,'Special thanks goes to:');
  setcolor  (lightred,black);
  writexy   (10,12,'My teacher Massimo Ferri for this nice idea!');
  setcolor  (white,black);
  writexy   (10,25,'Hit any key to continue. Possibly without using your head! ;)');
  ch := readkey;
  setcolor  (red,red);
  clrscr;
  fillchar  (scr,sizeof(scr),chr(32));
  getimage  (scr);
  transform (scr);
  saveimage (scr);
  setcolor  (white,black);
  clrscr;
  writexy   (1,1,'That''s all folks!!!');
End.