?login_element?

Subversion Repositories NedoOS

Rev

Blame | Last modification | View Log | Download

  1. Program UfoBookScreen;
  2. uses Crt,Dos,Graph;
  3. type
  4.   Data = string[25];
  5. const
  6.   Max=59;
  7.   N : word = 94;
  8.   current : byte = 1;
  9.   Path : string = 'D:\SPECTRUM\NAKL-60\';
  10.   GrMode : byte = 1;         {0 .. 5}
  11.   Size   : integer = 249;    {1 .. 512}
  12.   Double : byte = 1;         {1 .. 2}
  13.   Ins    : boolean =false;
  14.   Column : byte = 1;         {1 .. 4}
  15.   Row    : byte = 1;         {1 ...}
  16. var
  17.   Sc : array [0..31,0..191] of byte;
  18.   Num : array [0..9] of pointer;
  19.   Sym : array [1..10] of pointer;
  20.   i,j,k : integer;
  21.   F : Text;
  22.   FName,s: string;
  23.   c : char;
  24.   R : registers;
  25. {---------------------------------------}
  26. Procedure  Print(s : string);
  27. var
  28.   i:word;
  29. begin
  30.   for i:=1 to length(s) do
  31.     begin
  32.       repeat
  33.       r.ah:=2;
  34.       r.dx:=0;
  35.       Intr($17,r);
  36.       until (r.ah and $90)=$90;
  37.       r.ah:=0;
  38.       r.dx:=0;
  39.       r.al:=ord(s[i]);
  40.       Intr($17,r);
  41.     end
  42. end;
  43. {---------------------------------------}
  44. Procedure GetZXscr;
  45. begin
  46.   Assign(F,FName);
  47.   {$I-}
  48.   Reset(F);
  49.   {$I+}
  50.   if IOResult<>0 then begin SetTextStyle(1,0,5);
  51.                             for i:=0 to 31 do for j:=0 to 191 do
  52.                                  Sc[i,j]:=$AA;
  53.                             OutTextXY(20,320,'File Absent');
  54.                             FName:=Path+'Compact.$c';
  55.                             n:=94;
  56.                             exit;
  57.                           end;
  58.   for i:=1 to 17 do begin Read(F,c);end;
  59.   for k:=0 to 6143 do
  60.     begin
  61.       Read(F,c);
  62.       i:=k mod 32;
  63.       j:=k mod 2048;
  64.       j:=j div 256 + j mod 256 div 32 * 8 + (k - j) div 32;
  65.       Sc[i,j]:=ord(c);
  66.     end;
  67.   close(f);
  68. end;
  69. {---------------------------------------}
  70. Procedure Pause;
  71. begin
  72.   repeat until KeyPressed;
  73.   c:=ReadKey;
  74.   if c=#0 then c:=ReadKey;
  75. end;
  76. {---------------------------------------}
  77. Function InputStr(mess:string):string;
  78. var nx:byte;
  79. begin
  80.   while Keypressed do ReadKey;
  81.   SetFillStyle(1,Black);
  82.   OutTextXY(1,250,mess);
  83.   s:='';
  84.   nx:=0;
  85.   repeat
  86.   OutTextXY(1,290,'>'+s);
  87.   Pause;
  88.   case c of
  89.    ' '..#126: if nx < 40 then
  90.                           begin
  91.                             s:=s+c;
  92.                             nx:=nx+1;
  93.                           end;
  94.    #13:begin InputStr:=s; exit; end;
  95.    #0:ReadKey;
  96.    #08:if nx > 0 then
  97.                           begin
  98.                             Delete(s,length(s),1);
  99.                             nx:=nx-1;
  100.                             Bar(1,290,800,330);
  101.                           end;
  102.   end;
  103.   until false;
  104. end;
  105. {---------------------------------------}
  106. Procedure GetFName;
  107. var
  108.   nn : integer;
  109.   name:string[8];
  110. begin
  111.   SetColor(Green);
  112.   SetBkColor(Black);
  113.   if ins then
  114.     begin
  115.       name:=InputStr('Input Cassette Number:');
  116.       val(name,nn,i);
  117.       if i<>0 then exit;
  118.       n:=nn;
  119.       str(n,name);
  120.       name:=name+'-60';
  121.     end
  122.   else
  123.     begin
  124.      name:=InputStr('Input ZX Screen Name:');
  125.      if name='' then exit;
  126.  
  127.     end;
  128.   FName:=Path+name+'.$C';
  129. end;
  130. {---------------------------------------}
  131. Procedure OpenGr;
  132. begin
  133.   j:=detect;
  134.   i:=1;
  135.   InitGraph(j,i,'D:\TP7\BGI');
  136.   if GraphResult <> grOk then begin writeln('Graph Mode Error');Halt(1);end;
  137.   SetColor(LightGray);
  138. end;
  139. {---------------------------------------}
  140. Procedure CloseGr;
  141. begin CloseGraph end;
  142. {---------------------------------------}
  143. Procedure ViewZXscr(x:word);
  144. var m:byte;
  145. begin
  146.  for i:=0 to 191 do
  147.   begin
  148.   SetColor(Red);
  149.   Line(x+0,i+2,x+255,i+2);
  150.   for j:=0 to 31 do
  151.    begin
  152.    m:=Sc[j,i];
  153.    for k:=0 to 7 do
  154.       begin
  155.       PutPixel(x+j*8+k,i,(1-(128 and m) div 128)*LightGray);
  156.       m:=m shl 1
  157.      end;
  158.    end;
  159.   end;
  160. end;
  161. {---------------------------------------}
  162.  
  163. Function PrintLine(pos : integer) : boolean;
  164. var
  165.  rw,x,y,i,len :integer;
  166.  d,b : byte;
  167. begin
  168.  PrintLine:=true;
  169.  len:=Size*Column*Double;
  170.  s:=#27'*'+chr(GrMode)+chr(len mod 256)+chr(len div 256);
  171.  print(s);
  172.  y:=pos*8;
  173.  for rw:=1 to Column do
  174.  for x:=0 to Size-1 do
  175.   begin
  176.    b:=0;
  177.    for i:=0 to 7 do
  178.      b:=b shl 1 + ( GetPixel(x,y+i) and 1 ) xor 1;
  179.    for d:=1 to Double do  print(chr(b));
  180.    if KeyPressed then
  181.        if Readkey=#27  then
  182.         begin
  183.           PrintLine:=false;
  184.           Exit;
  185.         end;
  186.   end;
  187. end;
  188. {---------------------------------------}
  189. Procedure PrintZXscr;
  190. var
  191.   endline:byte;
  192. begin
  193.   endline:=23;
  194.   if Ins then endline:=26;
  195.   SetColor(Red);
  196.   OutTextXY(20,280,'Printing...');
  197.   for i:=1 to Row do
  198.    begin
  199.    print(#27#51#23);
  200.    for j:=0 to endline do
  201.     if not PrintLine(j) then
  202.         begin
  203.            R.AH:=1;
  204.            R.DX:=0;
  205.            Intr($17,R);
  206.            Print(#13#10);
  207.            exit;
  208.         end
  209.       else Print(#13#10);
  210.    end
  211. end;
  212. {---------------------------------------}
  213. Procedure Setup;
  214. begin
  215.  ClrScr;
  216.  TextColor(Yellow);
  217.  GoToXY(5,5);WriteLn('MultiPRINT v4.0   (c) 1993,94  Mednonogov bros.');
  218.  GoToXY(1,10);
  219.  TextColor(Cyan);
  220.  Write('Раздел экранных файлов (',Path,'): ');Readln(s);
  221.  if s<>'' then Path:=s;
  222.  Write('Использовать боковую вставку [Y/n]? ');Readln(s);
  223.  if (s='n') or (s='N') then Ins:=false else Ins:=true;
  224.  Write('Ширина картинки (',Size,'): ');Readln(s);
  225.  if s<>'' then Val(s,Size,i);
  226.  Write('Графический режим (',GrMode,'): ');Readln(s);
  227.  if s<>'' then Val(s,GrMode,i);
  228.  case GrMode of
  229.   1,2: Double:=2;
  230.   3  : Double:=4;
  231.   else Double:=1;
  232.  end
  233. end;
  234. {---------------------------------------}
  235. Procedure ClrZXscr;
  236. begin
  237.   SetFillStyle(1,Black);
  238.   Bar(0,0,520,217);
  239. end;
  240. {---------------------------------------}
  241. Procedure CCat;
  242. label
  243.   Bye;
  244. const
  245.       us:array [0..23] of string=('b1','b2','b3','b4',
  246.                                   'b5','b6','b7','b8',
  247.                                   'b9','b10','b11','b12',
  248.                                   'b13','b14','b15','b16',
  249.                                   'ng','nh','ni','nj',
  250.                                   'nk1','nk2','nk3','nk4');
  251. var
  252.   oldDouble,OldGrMode,oldSize,page,sc,i,j,k,mm:integer;
  253.   oldIns,void:boolean;
  254.   name: string;
  255.   ns:array[0..1] of string;
  256. begin
  257.   oldSize:=Size;
  258.   oldIns:=Ins;
  259.   oldDouble:=Double;
  260.   oldGrMode:=GrMode;
  261.   Size:=512;
  262.   Ins:=False;
  263.   Double:=1;
  264.   GrMode:=5;
  265.   sc:=0;
  266.       for mm:=0 to 2 do
  267.       begin
  268.       ClrZXscr;
  269.       for i:=0 to 3 do
  270.        begin
  271.         for j:=0 to 1 do
  272.         begin
  273.           Fname:=us[sc]+'.$c';
  274.           sc:=sc+1;
  275.           GetZXscr;
  276.           ViewZXscr(j*256);
  277.         end;
  278.         print(#27#51#23);
  279.         for j:=0 to 23 do
  280.          begin
  281.             void:=not PrintLine(j);
  282.             print(#13);
  283.             if void or not PrintLine(j)  then
  284.              begin
  285.                R.AH:=1;
  286.                R.DX:=0;
  287.                Intr($17,R);
  288.                Print(#13#10);
  289.                goto Bye;
  290.              end
  291.             else Print(#13#10);
  292.          end;
  293.        end;
  294.        ClrZXscr;
  295.        SetColor(Yellow);
  296.        OutTextXY(20,40,'End of page ');
  297.        Pause;
  298.        if c=#27 then begin ClrZXscr; goto Bye end;
  299.     end;
  300. Bye: ClrZXscr;
  301.    OutTextXY(20,100,'End of book graphics!');
  302.    Pause;
  303.    ClrZXscr;
  304.    Size:=oldSize;
  305.    Ins:=oldIns;
  306.    GrMode:=oldGrMode;
  307.    Double:=oldDouble;
  308. end;
  309. {---------------------------------------}
  310. Procedure Single ;
  311. label
  312.      Bye;
  313. const
  314.       us:array [0..3] of string=('nb','n1','n5','n4');
  315. var
  316.   oldDouble,OldGrMode,oldSize,page,sc,i,j,k,mm:integer;
  317.   oldIns,void:boolean;
  318.   name: string;
  319.   ns:array[0..1] of string;
  320. begin
  321.   oldSize:=Size;
  322.   oldIns:=Ins;
  323.   oldDouble:=Double;
  324.   oldGrMode:=GrMode;
  325.   Size:=512;
  326.   Ins:=False;
  327.   Double:=1;
  328.   GrMode:=5;
  329.   sc:=0;
  330.       for i:=0 to 1 do
  331.        begin
  332.         for j:=0 to 1 do
  333.         begin
  334.           Fname:=us[sc]+'.$c';
  335.           sc:=sc+1;
  336.           GetZXscr;
  337.           ViewZXscr(j*256);
  338.         end;
  339.         print(#27#51#23);
  340.         for j:=0 to 23 do
  341.          begin
  342.             void:=not PrintLine(j);
  343.             print(#13);
  344.             if void or not PrintLine(j)  then
  345.              begin
  346.                R.AH:=1;
  347.                R.DX:=0;
  348.                Intr($17,R);
  349.                Print(#13#10);
  350.                goto Bye;
  351.              end
  352.             else Print(#13#10);
  353.          end;
  354.        end;
  355. BYE: ClrZXscr;
  356.    OutTextXY(20,100,'End of Single graphics!');
  357.    Pause;
  358.    ClrZXscr;
  359.    Size:=oldSize;
  360.    Ins:=oldIns;
  361.    GrMode:=oldGrMode;
  362.    Double:=oldDouble;
  363. end;
  364. {---------------------------------------}
  365.  
  366. Procedure MainMenu;
  367. begin
  368.   repeat
  369.   SetFillStyle(1,Black);
  370.   Bar (1,216,500,380);
  371.   SetColor(LightGray);
  372.   SetTextStyle(1,0,4);
  373.   OutTextXY(02,390,'Print  graphics for');
  374.   OutTextXY(02,420,'UFO book (press B or 1)');
  375.   Pause;
  376.   case c of
  377.   #0:Readkey;
  378.   'B','b':CCat;
  379.   '1':single;
  380.   #27,'Q','q':begin CloseGr; Halt(0); end;
  381.   end;
  382.   until false;
  383. end;
  384. {---------------------------------------}
  385. begin
  386. {  SetUp;}
  387.   OpenGr;
  388.   MainMenu;
  389. end.