SVN операционной системы NedoOS для ZX-Evo

Program UfoBookScreen;
uses Crt,Dos,Graph;
type
  Data = string[25];
const
  Max=59;
  N : word = 94;
  current : byte = 1;
  Path : string = 'D:\SPECTRUM\NAKL-60\';
  GrMode : byte = 1;         {0 .. 5}
  Size   : integer = 249;    {1 .. 512}
  Double : byte = 1;         {1 .. 2}
  Ins    : boolean =false;
  Column : byte = 1;         {1 .. 4}
  Row    : byte = 1;         {1 ...}
var
  Sc : array [0..31,0..191] of byte;
  Num : array [0..9] of pointer;
  Sym : array [1..10] of pointer;
  i,j,k : integer;
  F : Text;
  FName,s: string;
  c : char;
  R : registers;
{---------------------------------------}
Procedure  Print(s : string);
var
  i:word;
begin
  for i:=1 to length(s) do
    begin
      repeat
      r.ah:=2;
      r.dx:=0;
      Intr($17,r);
      until (r.ah and $90)=$90;
      r.ah:=0;
      r.dx:=0;
      r.al:=ord(s[i]);
      Intr($17,r);
    end
end;
{---------------------------------------}
Procedure GetZXscr;
begin
  Assign(F,FName);
  {$I-}
  Reset(F);
  {$I+}
  if IOResult<>0 then begin SetTextStyle(1,0,5);
                            for i:=0 to 31 do for j:=0 to 191 do
                                 Sc[i,j]:=$AA;
                            OutTextXY(20,320,'File Absent');
                            FName:=Path+'Compact.$c';
                            n:=94;
                            exit;
                          end;
  for i:=1 to 17 do begin Read(F,c);end;
  for k:=0 to 6143 do
    begin
      Read(F,c);
      i:=k mod 32;
      j:=k mod 2048;
      j:=j div 256 + j mod 256 div 32 * 8 + (k - j) div 32;
      Sc[i,j]:=ord(c);
    end;
  close(f);
end;
{---------------------------------------}
Procedure Pause;
begin
  repeat until KeyPressed;
  c:=ReadKey;
  if c=#0 then c:=ReadKey;
end;
{---------------------------------------}
Function InputStr(mess:string):string;
var nx:byte;
begin
  while Keypressed do ReadKey;
  SetFillStyle(1,Black);
  OutTextXY(1,250,mess);
  s:='';
  nx:=0;
  repeat
  OutTextXY(1,290,'>'+s);
  Pause;
  case c of
   ' '..#126: if nx < 40 then
                          begin
                            s:=s+c;
                            nx:=nx+1;
                          end;
   #13:begin InputStr:=s; exit; end;
   #0:ReadKey;
   #08:if nx > 0 then
                          begin
                            Delete(s,length(s),1);
                            nx:=nx-1;
                            Bar(1,290,800,330);
                          end;
  end;
  until false;
end;
{---------------------------------------}
Procedure GetFName;
var
  nn : integer;
  name:string[8];
begin
  SetColor(Green);
  SetBkColor(Black);
  if ins then
    begin
      name:=InputStr('Input Cassette Number:');
      val(name,nn,i);
      if i<>0 then exit;
      n:=nn;
      str(n,name);
      name:=name+'-60';
    end
  else
    begin
     name:=InputStr('Input ZX Screen Name:');
     if name='' then exit;

    end;
  FName:=Path+name+'.$C';
end;
{---------------------------------------}
Procedure OpenGr;
begin
  j:=detect;
  i:=1;
  InitGraph(j,i,'D:\TP7\BGI');
  if GraphResult <> grOk then begin writeln('Graph Mode Error');Halt(1);end;
  SetColor(LightGray);
end;
{---------------------------------------}
Procedure CloseGr;
begin CloseGraph end;
{---------------------------------------}
Procedure ViewZXscr(x:word);
var m:byte;
begin
 for i:=0 to 191 do
  begin
  SetColor(Red);
  Line(x+0,i+2,x+255,i+2);
  for j:=0 to 31 do
   begin
   m:=Sc[j,i];
   for k:=0 to 7 do
      begin
      PutPixel(x+j*8+k,i,(1-(128 and m) div 128)*LightGray);
      m:=m shl 1
     end;
   end;
  end;
end;
{---------------------------------------}

Function PrintLine(pos : integer) : boolean;
var
 rw,x,y,i,len :integer;
 d,b : byte;
begin
 PrintLine:=true;
 len:=Size*Column*Double;
 s:=#27'*'+chr(GrMode)+chr(len mod 256)+chr(len div 256);
 print(s);
 y:=pos*8;
 for rw:=1 to Column do
 for x:=0 to Size-1 do
  begin
   b:=0;
   for i:=0 to 7 do
     b:=b shl 1 + ( GetPixel(x,y+i) and 1 ) xor 1;
   for d:=1 to Double do  print(chr(b));
   if KeyPressed then
       if Readkey=#27  then
        begin
          PrintLine:=false;
          Exit;
        end;
  end;
end;
{---------------------------------------}
Procedure PrintZXscr;
var
  endline:byte;
begin
  endline:=23;
  if Ins then endline:=26;
  SetColor(Red);
  OutTextXY(20,280,'Printing...');
  for i:=1 to Row do
   begin
   print(#27#51#23);
   for j:=0 to endline do
    if not PrintLine(j) then
        begin
           R.AH:=1;
           R.DX:=0;
           Intr($17,R);
           Print(#13#10);
           exit;
        end
      else Print(#13#10);
   end
end;
{---------------------------------------}
Procedure Setup;
begin
 ClrScr;
 TextColor(Yellow);
 GoToXY(5,5);WriteLn('MultiPRINT v4.0   (c) 1993,94  Mednonogov bros.');
 GoToXY(1,10);
 TextColor(Cyan);
 Write('Раздел экранных файлов (',Path,'): ');Readln(s);
 if s<>'' then Path:=s;
 Write('Использовать боковую вставку [Y/n]? ');Readln(s);
 if (s='n') or (s='N') then Ins:=false else Ins:=true;
 Write('Ширина картинки (',Size,'): ');Readln(s);
 if s<>'' then Val(s,Size,i);
 Write('Графический режим (',GrMode,'): ');Readln(s);
 if s<>'' then Val(s,GrMode,i);
 case GrMode of
  1,2: Double:=2;
  3  : Double:=4;
  else Double:=1;
 end
end;
{---------------------------------------}
Procedure ClrZXscr;
begin
  SetFillStyle(1,Black);
  Bar(0,0,520,217);
end;
{---------------------------------------}
Procedure CCat;
label
  Bye;
const
      us:array [0..23] of string=('b1','b2','b3','b4',
                                  'b5','b6','b7','b8',
                                  'b9','b10','b11','b12',
                                  'b13','b14','b15','b16',
                                  'ng','nh','ni','nj',
                                  'nk1','nk2','nk3','nk4');
var
  oldDouble,OldGrMode,oldSize,page,sc,i,j,k,mm:integer;
  oldIns,void:boolean;
  name: string;
  ns:array[0..1] of string;
begin
  oldSize:=Size;
  oldIns:=Ins;
  oldDouble:=Double;
  oldGrMode:=GrMode;
  Size:=512;
  Ins:=False;
  Double:=1;
  GrMode:=5;
  sc:=0;
      for mm:=0 to 2 do
      begin
      ClrZXscr;
      for i:=0 to 3 do
       begin
        for j:=0 to 1 do
        begin
          Fname:=us[sc]+'.$c';
          sc:=sc+1;
          GetZXscr;
          ViewZXscr(j*256);
        end;
        print(#27#51#23);
        for j:=0 to 23 do
         begin
            void:=not PrintLine(j);
            print(#13);
            if void or not PrintLine(j)  then
             begin
               R.AH:=1;
               R.DX:=0;
               Intr($17,R);
               Print(#13#10);
               goto Bye;
             end
            else Print(#13#10);
         end;
       end;
       ClrZXscr;
       SetColor(Yellow);
       OutTextXY(20,40,'End of page ');
       Pause;
       if c=#27 then begin ClrZXscr; goto Bye end;
    end;
Bye: ClrZXscr;
   OutTextXY(20,100,'End of book graphics!');
   Pause;
   ClrZXscr;
   Size:=oldSize;
   Ins:=oldIns;
   GrMode:=oldGrMode;
   Double:=oldDouble;
end;
{---------------------------------------}
Procedure Single ;
label
     Bye;
const
      us:array [0..3] of string=('nb','n1','n5','n4');
var
  oldDouble,OldGrMode,oldSize,page,sc,i,j,k,mm:integer;
  oldIns,void:boolean;
  name: string;
  ns:array[0..1] of string;
begin
  oldSize:=Size;
  oldIns:=Ins;
  oldDouble:=Double;
  oldGrMode:=GrMode;
  Size:=512;
  Ins:=False;
  Double:=1;
  GrMode:=5;
  sc:=0;
      for i:=0 to 1 do
       begin
        for j:=0 to 1 do
        begin
          Fname:=us[sc]+'.$c';
          sc:=sc+1;
          GetZXscr;
          ViewZXscr(j*256);
        end;
        print(#27#51#23);
        for j:=0 to 23 do
         begin
            void:=not PrintLine(j);
            print(#13);
            if void or not PrintLine(j)  then
             begin
               R.AH:=1;
               R.DX:=0;
               Intr($17,R);
               Print(#13#10);
               goto Bye;
             end
            else Print(#13#10);
         end;
       end;
BYE: ClrZXscr;
   OutTextXY(20,100,'End of Single graphics!');
   Pause;
   ClrZXscr;
   Size:=oldSize;
   Ins:=oldIns;
   GrMode:=oldGrMode;
   Double:=oldDouble;
end;
{---------------------------------------}

Procedure MainMenu;
begin
  repeat
  SetFillStyle(1,Black);
  Bar (1,216,500,380);
  SetColor(LightGray);
  SetTextStyle(1,0,4);
  OutTextXY(02,390,'Print  graphics for');
  OutTextXY(02,420,'UFO book (press B or 1)');
  Pause;
  case c of
  #0:Readkey;
  'B','b':CCat;
  '1':single;
  #27,'Q','q':begin CloseGr; Halt(0); end;
  end;
  until false;
end;
{---------------------------------------}
begin
{  SetUp;}
  OpenGr;
  MainMenu;
end.
Subversion Repositories NedoOS

(root)/src/games/ufo2/PASCAL/XBOOK.PAS – Rev 995
