home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / KAYPRO / K4SKETCH.LBR / K4SKETCH.PZS / K4SKETCH.PAS
Pascal/Delphi Source File  |  2000-06-30  |  13KB  |  435 lines
  1. program Sketch;  { 2/13/86    version 1.0 }
  2.  
  3. {  Program to draw lines and pixels and video attributes of characters }
  4. {  on Kaypro '84 series CP/M computers with graphics.                  }
  5.  
  6. {  Written with Turbo Pascal Version 2                     }
  7. {  By Eric Mausolf, Seattle, Washington.                   }
  8.  
  9. var
  10.   Ch, Mode       : Char;
  11.   V, H, VM, HM, code   : Integer;
  12.   X              : Byte;
  13.  
  14. const
  15.    HiBound        = 36;
  16.    LoBound        = 131;
  17.    RightBound     = 191;
  18.    LeftBound      = 32;
  19.  
  20. Type
  21.    String3 = String[3];
  22.  
  23.         { procedures to access Kaypro graphics }
  24. procedure CursOn;     begin write(#27,'B4'); end;
  25. procedure CursOff;    begin write(#27,'C4'); end;
  26. procedure Gray;       begin write(#27,'B0',#27,'B1'); end;
  27. procedure UnGray;     begin write(#27,'C0',#27,'C1'); end;
  28. procedure Blink;      begin write(#27,'B2'); end;
  29. procedure UnBlink;    begin write(#27,'C2'); end;
  30. procedure Score;      begin write(#27,'B3'); end;
  31. procedure UnScore;    begin write(#27,'C3'); end;
  32. procedure Invert;     begin write(#27,'B0'); end;
  33. procedure UnInvert;   begin write(#27,'C0'); end;
  34. procedure Dim;        begin write(#27,'B1'); end;
  35. procedure UnDim;      begin write(#27,'C1'); end;
  36. procedure Normal;     begin UnGray;UnBlink;UnScore; end;
  37. procedure Draw(V1,H1,V2,H2 : Byte);
  38.    begin  write(#27,'L',chr(V1),chr(H1),chr(V2),chr(H2)); end;
  39. procedure UnDraw(V1,H1,V2,H2 : Byte);
  40.    begin  write(#27,'D',chr(V1),chr(H1),chr(V2),chr(H2)); end;
  41.  
  42. {$I Greet.mod}
  43.  
  44. procedure PixOn;  {write pixel at current position}
  45.  begin      write(#27,'*',chr(V),chr(H));   end;
  46.  
  47. procedure PixOff;  {erase pixel at current position}
  48.  begin      write(#27,' ',chr(V),chr(H));   end;
  49.  
  50. procedure StartMessage; { move cursor to message area }
  51.  begin  GotoXY(50,1);  end;
  52.  
  53. procedure EraseMessage; { erase message at end of status line }
  54.  begin
  55.    Gray;
  56.    StartMessage; write('                               ');
  57.    unGray;
  58.  end;
  59.  
  60. procedure GetChar(var answer : Char);
  61. begin
  62.   Read(kbd,answer);
  63.   answer := UpCase(answer);
  64. end;
  65.  
  66.  
  67. Procedure ModeShow;
  68. begin  Gray;
  69.   GotoXY(9,1);
  70.   Case Mode of
  71.    'E' : write('Erase');
  72.    'D' : write('Draw ');
  73.   end;  UnGray;
  74. end;
  75.  
  76. procedure VectShow;
  77. begin  Gray;
  78.   GotoXY(26,1); If mode = 'W' then write(H,' ') else write(V,' ');
  79.   GotoXY(41,1); If mode = 'W' then write(V,' ') else write(H,' ');
  80.   UnGray;
  81. end;
  82.  
  83.  
  84. procedure MemShow;  { show memory setting if it has been set yet }
  85. begin
  86.   EraseMessage; startmessage;
  87.   If Mode <> 'W' then begin
  88.      Gray;
  89.      if HM = 0 then  write('    Press H for Help')
  90.      else  write('    Mem: ',VM,'  /  ',HM);  UnGray;
  91.   end;
  92. end;
  93.  
  94.  
  95. procedure Grayline;
  96. begin
  97.   GotoXY(1,1); Gray;
  98.   for X := 1 to 80 do write(' ');
  99.   GotoXY(1,1); UnGray;
  100. end;
  101.  
  102.  
  103. procedure StatLine;   { WRITE STATUS LINE }
  104. begin
  105.   Grayline; Gray;
  106.   GotoXY(3,1);  write('Mode: ');
  107.   GotoXY(20,1); If Mode = 'W' then write('   X: ') else write('Vert: ');
  108.   GotoXY(34,1); If Mode = 'W' then write('    Y: ') else write('Horiz: ');
  109.   If mode = 'W' then begin
  110.      StartMessage; write(' Press <ESC> for options');
  111.   end;
  112.   ModeShow;
  113.   VectShow;
  114.   MemShow;
  115. end;
  116.  
  117.  
  118. procedure Help;
  119. var Choose , press : char;
  120. begin
  121.   PixOn;       { keep cursor showing }
  122.   choose := ' ';
  123.   Grayline; Ungray;invert; write(' HELP ');Gray;
  124.   write('  Describe which command?  E, D, Q, M, R, L, N, C, J, P, W, <ESC> to skip ');
  125.   repeat
  126.      GetChar(choose);
  127.   until choose in ['E','D','Q','M','R','L','N','C','J','P','W',#27];
  128.   Grayline;Gray;
  129.   case choose of
  130.    'E' : write(' E: Set cursor keys and functions to Erase (move w/o drawing).');
  131.    'D' : write(' D: Set cursor keys and functions to Draw.');
  132.    'Q' : write(' Q: Quit to system.');
  133.    'M' : write(' M: Store current cursor position in Memory for use with R and L.');
  134.    'R' : write(' R: Return cursor to position stored in Memory.');
  135.    'L' : write(' L: Draw or Erase a Line to position stored in Memory.');
  136.    'N' : write(' N: Clear Screen, retaining current Memory setting.');
  137.    'J' : write(' J: Jump to position you specify (answer prompts).');
  138.    'P' : write(' P: Draw or Erase line to position you specify (answer prompts).');
  139.    'C' : write(' C: Draw or Erase circle of specified radius from cursor.');
  140.    'W' : write(' W: Go into Write mode to write characters to the screen.');
  141.   end;
  142.   if choose <> #27 then begin
  143.      repeat
  144.        GotoXY(68,1);  write('Press <ESC>'); UnGray;
  145.        GetChar(press);
  146.      until press in [#27];
  147.   end;
  148.   Statline;
  149. end;
  150.  
  151.  
  152. procedure NewScreen;  { clear the screen, re-do status line }
  153. begin
  154.   ClrScr;
  155.   StatLine;
  156. end;
  157.  
  158.  
  159. procedure Memory; { Memory function }
  160. begin
  161.   VM := V;
  162.   HM := H;
  163.   MemShow;
  164. end;
  165.  
  166.  
  167. procedure Line; { Line function to draw line from cursor to }
  168. begin                          { coordinates in memory      }
  169.  if  VM > 0 then
  170.    Case Mode of
  171.      'D' : Draw(V,H,VM,HM);
  172.      'E' : UnDraw(V,H,VM,HM);
  173.    end;
  174. end;
  175.  
  176. procedure Return;  { function to return cursor to coordinates in memory }
  177. begin
  178.  if  VM > 0 then
  179.    begin
  180.      if Mode = 'E' then PixOff;  { to erase old cursor }
  181.      V := VM;  H := HM;
  182.      VectShow;
  183.    end;
  184. end;
  185.  
  186.  
  187. procedure Circle;        { draw and erase circles }
  188. var  Step  :  Real;
  189.     VO, HO,  VN, HN, Radius      : Integer;
  190.     RadiusStr: String3;
  191. begin
  192.     PixOn;  { preserve cursor }
  193.     Repeat
  194.        EraseMessage; StartMessage; Gray; write('    C: Radius = ');
  195.        Read(RadiusStr);
  196.        Val(RadiusStr, Radius,Code); If code <>0 then write(^G);
  197.     Until Code = 0;
  198.    UnGray;
  199.    Step := 0.3;
  200.    HO := H + Radius;  VO := V;
  201.    for X := 1 to 21 do begin
  202.       HN := Trunc(Radius * Cos(step) + H) ;
  203.       VN := Trunc(- Radius * Sin(Step) + V);
  204.       If Mode = 'D' then Draw(VO,HO, VN,HN)
  205.           else UnDraw(VO,HO,VN,HN);
  206.       HO := HN ; VO := VN;
  207.       step := step + 0.3;
  208.    end;
  209.    MemShow;
  210. end;
  211.  
  212. procedure Plot;
  213. var OK  :  Boolean;   VN, HN,Code : Integer;
  214.            VNStr, HNStr: String3;
  215. begin
  216.   PixOn;  { preserve cursor }
  217.     Repeat
  218.       Gray;
  219.       StartMessage; write('P: Vertical Coord. = ');
  220.       Read(VNStr); Val(VNstr,VN, Code);
  221.       If not ((code = 0) and ( VN in [HiBound..LoBound] )) then write(^G);
  222.       EraseMessage;
  223.     Until (Code = 0) and ( VN in [HiBound..LoBound] ) ;
  224.     Repeat
  225.        StartMessage; Gray; write('P: Horizontal Coord. = ');
  226.        Read(HNStr); Val(HNStr,HN,Code);
  227.        If not ((code= 0) and (HN in [leftbound..rightbound]))then write(^G);
  228.        EraseMessage;
  229.    Until (Code =0) and (HN in [leftbound..rightbound]);
  230.   EraseMessage; UnGray;
  231.   Case Mode of
  232.      'D' : Draw(V,H,VN,HN);
  233.      'E' : UnDraw(V,H,VN,HN);
  234.     end;
  235.   MemShow;
  236. end;
  237.  
  238.  
  239. procedure Jump;
  240. var  VN, HN,Code : Integer;
  241.            VNStr, HNStr: String3;
  242. begin
  243.   PixOn;  { preserve cursor }
  244.     Repeat
  245.       Gray;
  246.       StartMessage; write('J: Vertical Coord. = ');
  247.       Read(VNStr); Val(VNstr,VN, Code);
  248.       If not ((code = 0) and (VN in [hibound..lobound])) then write(^G);
  249.       EraseMessage;
  250.     Until (Code = 0) and ( VN in [HiBound..LoBound] ) ;
  251.     Repeat
  252.        StartMessage; Gray; write('J: Horizontal Coord. = ');
  253.        Read(HNStr); Val(HNStr,HN,Code);
  254.        If not ((code = 0) and (HN in [leftbound..rightbound])) then write(^G);
  255.        EraseMessage;
  256.    Until (Code =0) and (HN in [leftbound..rightbound]);
  257.    EraseMessage; UnGray;
  258.    if Mode = 'E' then PixOff;          { erase old cursor }
  259.    V := VN; H := HN;
  260.   VectShow;
  261.   MemShow;
  262. end;
  263.  
  264.  
  265. procedure CursGen;  { Generates Blinking cursor, waits for input, }
  266. begin               { Controls drawing functions                  }
  267.  repeat
  268.      delay(10);                              { This loop generates a blinking }
  269.      if Mode = 'E' then PixOn else PixOff;   { cursor and leaves the pixel    }
  270.      delay(10);                              { either on or off, depending on }
  271.      if Mode = 'E' then PixOff else PixOn;   { Mode.  It generates the graph- }
  272.  until KeyPressed;                           { ics controlled by cursor keys. }
  273.     GetChar(Ch);
  274.     Case Ch of
  275.       'L' :  Line;               { Jump to various procedures }
  276.       'M' :  Memory;             { that control functions.    }
  277.       'P' :  Plot;
  278.       'J' :  Jump;
  279.       'R' :  Return;
  280.       'C' :  Circle;
  281.       'H' :  Help;
  282.       'N' :  NewScreen;
  283.     end; { of case }
  284.  end;
  285.  
  286. procedure KeyFind;         { Determine what valid key was pressed }
  287. begin
  288.   Case Ch of
  289.      ^E :  V := V - 1;
  290.      ^X :  V := V + 1;
  291.      ^S :  H := H - 1;
  292.      ^D :  H := H + 1;
  293.      'E' :  Mode := 'E';
  294.      'D' :  Mode := 'D';
  295.      'Q' :  Mode := 'Q';
  296.      'W' :  Mode := 'W';
  297.    end;  {of case statement}
  298.       if V > LoBound    then V := LoBound;       { Keep cursor from     }
  299.       if V < HiBound    then V := HiBound;       { exceeding boundaries }
  300.       if H > RightBound then H := RightBound;
  301.      if H < LeftBound  then H := LeftBound;
  302. end;
  303.  
  304.  
  305. procedure EraseMode;
  306. begin
  307.   Repeat                            { Until new mode requested }
  308.     Repeat                             { Until acceptable answer gotten }
  309.       CursGen;
  310.     Until Ch in [^E,^X,^S,^D,'D','Q','W'];    { repeat return }
  311.      KeyFind;
  312.      VectShow;
  313.   Until Mode in ['D','Q','W'];                { loop unless mode change }
  314.   if Mode = 'D' then  ModeShow;
  315. end;
  316.  
  317. procedure DrawMode;
  318. begin
  319.   Repeat                             { Until new mode requested }
  320.     Repeat                           { Until acceptable answer gotten }
  321.       CursGen;
  322.     Until Ch in [^E,^X,^S,^D,'E','Q','W'];    { repeat return }
  323.     KeyFind;
  324.     VectShow;
  325.   Until Mode in ['E','Q','W'];                { loop unless mode change }
  326.   if Mode = 'E' then ModeShow;
  327. end;
  328.  
  329. Procedure CoordShow(Xc,Yc: Integer);  { show coordinates in write mode }
  330. begin
  331.    Gray;
  332.    GotoXY(26,1); write(Xc,'  ');
  333.    GotoXY(41,1); write(Yc,'  ');
  334.    ungray;
  335. end;
  336.  
  337. Procedure writeshow;
  338. begin
  339.    Gray; GotoXY(1,1);
  340.    write('  Mode: Write         X:             Y:           Press <ESC> for options   ');
  341.    UnGray;
  342. end;
  343.  
  344.  
  345. procedure WriteMode;
  346.    Var
  347.       WChar, AttChar, OldMode  : Char;
  348.       DimAtt,BlinkAtt, ScoreAtt,InvertAtt,GrayAtt : Boolean;
  349.  
  350.    Const
  351.       Xcoord : Integer = 30;
  352.       Ycoord : Integer = 15;
  353.  
  354. BEGIN
  355.    Wchar := '*'; AttChar := '*';
  356.    DimAtt := False; BlinkAtt := False; ScoreAtt := False;
  357.    InvertAtt := False; GrayAtt := False;
  358.    writeshow; CoordShow(Xcoord,Ycoord);
  359.    GotoXY(Xcoord,Ycoord);
  360.    CursOn;
  361.    Repeat
  362.      Read(kbd,WChar);
  363.      Case WChar of
  364.        ^S : Xcoord := Xcoord - 1;
  365.        ^H : Xcoord := Xcoord - 1;
  366.        ^D : Xcoord := Xcoord + 1;
  367.        ^E : Ycoord := Ycoord - 1;
  368.        ^X : Ycoord := Ycoord + 1;
  369.       #127:  begin
  370.                Xcoord := Xcoord - 1;
  371.                GotoXY(Xcoord,Ycoord);
  372.                Write(' ');
  373.                GotoXY(Xcoord,Ycoord);
  374.             end;
  375.        else if Xcoord = 80 then Xcoord := 79;
  376.      end;  { of case }
  377.      If Xcoord < 1 then Xcoord :=1;
  378.      If Ycoord < 2 then Ycoord := 2;
  379.      If Xcoord > 80 then Xcoord := 80;
  380.      If Ycoord > 25 then Ycoord := 25;
  381.      {If (Wchar = ' ') and (Xcoord = 80) then Xcoord := 79;}
  382.      if WChar = #27 then begin      {Options section}
  383.        CursOff; Grayline; Gray;
  384.        Write(' <D>im, <B>link, <U>nderline, <W>hite, <G>ray, <N>ormal, <ESC> change Mode');
  385.        Repeat
  386.          Read(kbd,AttChar); AttChar := UpCase(AttChar);
  387.        Until AttChar in ['D','B','U','W','G','N',#27];
  388.        Case Attchar of
  389.           'D' : DimAtt    := True;
  390.           'B' : BlinkAtt  := True;
  391.           'U' : ScoreAtt  := True;
  392.           'W' : InvertAtt := True;
  393.           'G' : GrayAtt   := True;
  394.           'N' : begin
  395.                    DimAtt := False; BlinkAtt := False; ScoreAtt := False;
  396.                    InvertAtt := False; GrayAtt := False;
  397.                 end;
  398.          end;            {of case}
  399.        Writeshow;
  400.        CoordShow(Xcoord,Ycoord); GotoXY(Xcoord,YCoord); CursOn;
  401.      end;                                         {of options section}
  402.        if not (WChar in [^S,^X,^D,^E,^H,#27,#127]) then begin
  403.          if DimAtt    = True then Dim;
  404.          if BlinkAtt  = True then Blink;
  405.          if ScoreAtt  = True then Score;
  406.          if InvertAtt = True then Invert;
  407.          if GrayAtt   = True then Gray;
  408.          write(Wchar);
  409.          Xcoord := Xcoord + 1; Normal
  410.       end;
  411.       CoordShow(xCoord,Ycoord); GotoXY(Xcoord,Ycoord); CursOn;
  412.    Until AttChar = #27;
  413.    Mode := 'E';
  414.    CursOff; Statline;
  415. END;
  416.  
  417.  
  418.  
  419. begin                            { MAIN BLOCK }
  420.   CursOff;
  421.   open;
  422.     V := 82; H:= 112;
  423.     VM := 0; HM := 0;
  424.     ClrScr;
  425.     Mode := 'E';
  426.     Statline;
  427.       While Mode <> 'Q' do       { Main Loop }
  428.          begin Case Mode of
  429.             'E' : EraseMode;
  430.             'D' : DrawMode;
  431.             'W' : WriteMode;
  432.          end;
  433.       end;
  434.   ClrScr;CursOn;
  435. end.