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 / CPM / EDUCATIN / ALPHABET.ARK / ALPHA.PAS < prev   
Pascal/Delphi Source File  |  1988-04-10  |  9KB  |  329 lines
  1. program alpha;
  2.  
  3. { STRIPPED DOWN VERSION FOR CHRIS WILKERSON }
  4. { for displaying the block alphabet for Chris }
  5. { written for Turbo Pascal}
  6. { uses terminal specific features
  7.   1) gotoxy screen movement
  8.   2) ClrScr
  9. So you must use TINST to select ADM31 type terminal before
  10. you can get a version to work on the Morrow.
  11.  
  12. I suggest you get it to work on kaypro first.
  13.  
  14. }
  15.  
  16. { uses two font files alpha.chr and alpha.len that give
  17.   table of raster data, and pointers to that data. It
  18.   would be possible to incoporate this into the program,
  19.   but I never got around to it.
  20. }
  21.  
  22.  
  23. {$R+}
  24. {$C-}
  25. type power = array[0..7] of byte;
  26.      rownum = 0..23;
  27.      colnum = 0..79;
  28.      name =   string[25];
  29.  
  30.  
  31. const
  32.     NROWS = 23; { 0-23 }
  33.     NCOLS = 79; { 0-79 }
  34.     pow2 : power = (1,2,4,8,16,32,64,128);
  35.     NUMCHR = $2000; { largest file of characters to read in }
  36.     defaultpath= ''; (* change to your main drive if you want *)
  37.  
  38. type
  39.     buf  = array[0..NUMCHR] of byte;
  40.     ourscrn = array[0..NROWS,0..NCOLS] of boolean;
  41.     virtscrn = ^ourscrn;
  42.     bufptr = ^buf;
  43. var
  44.    valid, mode : boolean;
  45.    maxrow,lomaxrow,currow : rownum;
  46.    maxcol,lomaxcol,curcol:  colnum;
  47.    gridmem  : virtscrn;
  48.    ch,c,CURRCHR    :  char;
  49.    i, oursize : integer;
  50.    infile : file;
  51.    inname : NAME;
  52.    plen   : array[32..255] of colnum;
  53.    poffset : array[32..255] of integer;
  54.    pbuf  : bufptr;
  55.  
  56.  
  57.  
  58. { we have 3 screens to contend with :
  59.   1) The physical screen (24 x 80)
  60.   2) the virtual screen in memory
  61.   3) the window on the virtual screen
  62.      that is actually displayed.
  63. }
  64.  
  65. procedure locate(row,col : integer );
  66. { goes to a point on the physical screen }
  67. begin
  68.     gotoxy(col+1,row+1);  { reversed!!!, (1,1) is top left }
  69. end ; { locate }
  70.  
  71.  
  72. procedure ourlocate(row,col: integer); { locate on our own grid }
  73. begin     {provide wraparound }
  74.           locate(row,((NCOLS-maxcol) div 2)+col);
  75. end; { our locate in the grid }
  76.  
  77. procedure home;
  78. begin
  79.     ourlocate(0,0);
  80.     currow:=0;
  81.     curcol:=0;
  82.  end;
  83.  
  84.  
  85. procedure setpt(row,col : integer);  { make a '#' mark }
  86. begin
  87.     ourlocate(row,col);
  88.     write(CURRCHR);
  89.     gridmem^[row,col]:=TRUE;
  90. end; { setpt }
  91.  
  92. procedure resetpt(row,col : integer); { make a '.' }
  93. begin
  94.     gridmem^[row,col]:=FALSE;
  95. end; { resetpt }
  96.  
  97. procedure drawgrid;
  98. { draw the grid using the data in gridmem }
  99. var  i,j : byte;
  100. begin
  101.      for i:=0 to lomaxrow do begin
  102.          for j:=0 to lomaxcol do begin
  103.              if gridmem^[i,j] then setpt(i,j) else resetpt(i,j);
  104.          end;
  105.      end;
  106.      home;
  107.  end; { make grid }
  108.  
  109.  
  110. procedure clrgrid;
  111. var i,j : byte;
  112. begin
  113.      for i:=0 to lomaxrow do begin
  114.          for j:=0 to lomaxcol do begin
  115.              gridmem^[i,j]:=FALSE;
  116.          end;
  117.      end;
  118. end; { clrgrid }
  119.  
  120.  
  121. procedure newscr ; { erase screen and home cursor }
  122. begin
  123.     ClrScr;
  124. end; { newscr }
  125.  
  126. procedure newpic;
  127. begin
  128.     newscr;
  129.     drawgrid;
  130.     home;
  131. end;
  132.  
  133.  
  134.  
  135. function min( x,y : integer) : integer;
  136. begin
  137.      if x > y then min:=y else min:=x;
  138. end;
  139.  
  140. procedure logo ; { what it does }
  141. begin
  142.    NEWSCR;
  143.    LOCATE(12,0);
  144.    WRITELN('                      ALPHABET AND NUMBER DRILL  ');
  145.    WRITELN;
  146.    WRITELN;
  147.    WRITELN('                          Clarence Wilkerson   ');
  148.    writeln;
  149.    writeln('                                  9/84 ');
  150.    WRITELN;
  151.    WRITELN;writeln;
  152.    WRITELN('>>>>>>       PRESS "A" for display mode, shows letter typed');
  153.    writeln;
  154.    writeln('             PRESS "R" for random test of lower case characters.');
  155.    writeln('                Child types letter to proceed. Six tries allowed.');
  156.    writeln;
  157.    writeln('             Use ^A (CTRL-A) to toggle modes.');
  158.    writeln;
  159.    writeln('             Use ^C (CTRL-C) to exit. Your choice? ..  ');
  160.    delay(1000);
  161. end;
  162.  
  163. procedure convert; { take length table and make an offset table }
  164. var sum,i : integer;
  165. begin
  166.     sum:=0;
  167.     for i:=32 to 127 do begin
  168.        poffset[i]:=sum; { runs one position behind }
  169.        sum:=sum+3*plen[i]; { plen is in terms of vertical bars, so mult by 3}
  170.     end; {i}
  171.  end;{convert}
  172.  
  173. procedure flushkbd; { get rid of characters typed after the displayed one }
  174. var c : char;
  175. begin
  176.   while keypressed do  read(kbd,c);
  177.   { gobble up queue of characters typed }
  178. end;
  179.  
  180.  
  181. FUNCTION fetch(auto: BOOLEAN) : integer;
  182.  { get character from compressed form in memory, put on screen }
  183. var c : char;
  184.     x,i,j,k : integer;
  185.     y,u,s : integer;
  186. begin
  187.  
  188.  if not auto then begin { get and filter the choice of letter }
  189.     locate(1,1); write('Character? ');
  190.     read(KBD,c);
  191.     if ( ord(c) > 31) and ( ord(c) < 127) then write(c);
  192.     delay(500); { delay a bit to display choice before clearing screen }
  193.     if c = chr(3) then fetch:=0
  194.     else if c = chr(1) then fetch:=-1
  195.     else begin
  196.        fetch:=1;
  197.        x:=ord(c);
  198.        if ( x > 127) or (x < 32) then begin
  199.          c:='.';
  200.          x:=46;
  201.        end; { make it an period }
  202.  end;
  203.  end else if auto then begin
  204.      x:=0;
  205.      while x < 97 do x:=random(123); { lowercase only }
  206.      c:=chr(x);
  207.  end;
  208.  
  209.      currchr:=c; { make the display in terms of the character }
  210.      if plen[x]=0 then lomaxcol:=0 else lomaxcol:=plen[x]-1; { get the length }
  211.      { now read 3 bytes for each vertical bar }
  212.      lomaxcol:=min(lomaxcol,maxcol);
  213.  
  214.      for j:=0 to lomaxcol do begin  { all columns }
  215.        for k:=0 to 2 do begin  { 3 bars per column }
  216.           y:= poffset[x]+k+(3*j); { i is gotten by ANDING }
  217.           for i:=0 to 7 do begin { all rows }
  218.              s:=(k*8) +i;
  219.              gridmem^[s,j]:=(pbuf^[y] and pow2[7-i] <> 0);
  220.           end; {i}
  221.     end; { k }
  222.    end; { j }
  223.    newpic;
  224.    if not auto then begin
  225.        DELAY(1500); { KEEP THE PICTURE ON SCREEN FOR A WHILE }
  226.        flushkbd; { empty the queue of kbd characters to eliminate typeahead }
  227.     end
  228.    else if auto then begin
  229.       locate(4,50);
  230.       writeln(chr(7),'Type the matching letter.');
  231.       flushkbd;
  232.       c:=' ';
  233.       i:=0;
  234.       while ( c <> currchr) and ( i < 6 ) do begin
  235.          i:=i+1;
  236.          locate(5 + i,50);
  237.          write(chr(7),i,') ');
  238.          read(kbd,c);writeln(c);
  239.          if c = chr(3) then halt;
  240.          if c = chr(1) then begin
  241.              i:=100;  { to force exit }
  242.              fetch :=-1; { to switch modes }
  243.          end; { if c = chr(1) }
  244.       end; { while c <> }
  245.    end; { if auto }
  246.  
  247.   home;
  248.  end; { fetch }
  249.  
  250. procedure getinput( S : NAME); { open an input file }
  251. var valid : boolean;  { tries to open file s, if cannot, asks for new name }
  252. begin
  253.      inname:=s;
  254.      REPEAT
  255.         assign(infile,inname);
  256.         {$I-}
  257.         reset(infile);
  258.         valid:=(ioresult=0);
  259.         {$I+}
  260.         if not valid then begin
  261.             inname:=defaultpath + inname;
  262.             assign(infile,inname);
  263.             {$I-}
  264.             reset(infile);
  265.             valid:=(ioresult=0);
  266.             {$I+}
  267.             if not valid then begin
  268.                  write('File ',inname,' not found. Replacement? ');
  269.                  readln(inname);
  270.             end;
  271.         end;
  272.         writeln;
  273.      UNTIL VALID ;
  274. end; { getinput }
  275.  
  276. begin { main }
  277.       newscr;
  278.       logo;
  279.       readln(ch);
  280.       ch:=upcase(ch);
  281.       new(gridmem);
  282.       if gridmem = nil then writeln('Warning. Overflow on gridmem.');
  283.       new(pbuf);  { allocate the big stuff at run time }
  284.       if pbuf = nil then writeln('Warning. Overflow on pbuf.');
  285.       { clean file buffer area }
  286.       fillchar(pbuf^,Numchr,0);
  287.       for i:=0 to NUMCHR do pbuf^[i]:=0;
  288.       getinput('ALPHA.LEN');    { CHANGE DEFAULT DIRECTORY }
  289.       blockread(infile,plen[32],1); { 1 sector file }
  290.       close(infile);
  291.       convert;   { change plen data to poffset data }
  292.       writeln;
  293.       getinput('ALPHA.CHR');
  294.       oursize:=filesize(infile);
  295.       if oursize < (NUMCHR div 128) then blockread(infile,pbuf^[0],oursize)
  296.        else blockread(infile,pbuf^[0],(NUMCHR div 128));
  297.       close(infile);
  298.       maxrow:=23;
  299.       maxcol:=45;
  300.       lomaxrow:=maxrow;
  301.       lomaxcol:=maxcol;
  302.       clrgrid;
  303.       newpic;
  304.       home;
  305.       { begin with the indicated mode }
  306.       valid:=true;
  307.       if ch = 'R' then begin
  308.             mode:=TRUE;
  309.             gotoxy(1,1);writeln('Random Test Mode. Type character to continue.');
  310.             delay(500);
  311.       end
  312.       else begin
  313.             mode:=False;
  314.             gotoxy(1,1);writeln('Display Mode. Shows character typed.');
  315.             delay(500);
  316.       end;
  317.  
  318.       while valid do begin
  319.           i:= FETCH(mode);
  320.           if i = 0 then valid:=false;
  321.           if i = -1 then { switch modes } begin
  322.                gotoxy(1,1);
  323.                writeln('Switching modes.');
  324.                mode:= not mode;
  325.                delay(500);
  326.           end;
  327.      end;
  328.    newscr;
  329. end.