home *** CD-ROM | disk | FTP | other *** search
/ 8bitfiles.net/archives / archives.tar / archives / genie-commodore-file-library / C128CPM / GRC128.ZIP / KEYS.SRC < prev    next >
Encoding:
Text File  |  1991-06-15  |  9.9 KB  |  503 lines
  1. program zeichensatz;
  2.  
  3.     type edfield=array[1..8,1..8]of boolean;
  4.               valfield=array[1..8]of byte;
  5.  
  6.  
  7.     const esc=$1b;
  8.           return=13;
  9.  
  10.     var     c,d:char;
  11.         str:string;
  12.         texnta,offsa:integer;
  13.         buchst:char;
  14.             external function @bdos(number:integer;parm:word):integer;
  15.         
  16. procedure editval (var gesetzt:edfield;var tab:valfield);
  17.  
  18.     const stx=20;
  19.           sty=8;
  20.           lenx=8;
  21.           leny=8;
  22.  
  23.     var
  24.         xko,yko,xp,yp:integer;
  25.         x,y:integer;
  26.     
  27.  
  28. begin
  29.     auswahl;
  30.     clear;
  31.     wrtext;
  32.     scrpicture;
  33.     if c='1' then
  34.         for x:=1 to 8 do
  35.             for y:=1 to 8 do
  36.                 gesetzt[x,y]:=false
  37.     else
  38.         begin
  39.         readbitm(tab,d);
  40.         for y:=1 to 8 do
  41.             for x:=8 downto 1 do
  42.                 begin
  43.                 setcrsr(stx+8-x,sty+y-1);
  44.                 if (tab[y] div powers(2,x-1))>=1 then
  45.                     begin
  46.                     write('X');
  47.                     gesetzt[x,y]:=true
  48.                     end
  49.                 else
  50.                     begin
  51.                     write(' ');
  52.                     gesetzt[x,y]:=false
  53.                     end;
  54.                 tab[y]:=tab[y]mod powers(2,x-1)
  55.                 end
  56.         end;
  57.  
  58.  
  59.     xko:=stx;
  60.     yko:=sty;
  61.     xp:=8;
  62.     yp:=1;
  63.     repeat
  64.         repeat
  65.             setcrsr(xko,yko);
  66.             read(c);
  67.             setcrsr(xko,yko);
  68.             write('X');
  69.         until((c='s')or(c='d')or(c='e')or(c='x')or(c='q')or(c='w')or(c='r'));
  70.     case c of
  71. 's':    if xp<8 then
  72.         begin
  73.         setcrsr(xko,yko);
  74.         if gesetzt[xp,yp] then
  75.             write('X')
  76.         else
  77.             write(' ');
  78.         xp:=xp+1;
  79.         xko:=xko-1
  80.         end;
  81. 'd':    if xp>1 then
  82.         begin
  83.         setcrsr(xko,yko);
  84.         if gesetzt[xp,yp] then
  85.             write('X')
  86.         else
  87.             write(' ');
  88.         xp:=xp-1;
  89.         xko:=xko+1
  90.         end;
  91. 'e':    if yp>1 then
  92.         begin
  93.         setcrsr(xko,yko);
  94.         if gesetzt[xp,yp] then
  95.             write('X')
  96.         else
  97.             write(' ');
  98.         yp:=yp-1;
  99.         yko:=yko-1
  100.         end;
  101. 'x':    if yp<8 then
  102.         begin
  103.         setcrsr(xko,yko);
  104.         if gesetzt[xp,yp] then
  105.             write('X')
  106.         else
  107.             write(' ');
  108.         yp:=yp+1;
  109.         yko:=yko+1
  110.         end;
  111. 'q':    gesetzt[xp,yp]:=true;
  112.  
  113. 'r':    gesetzt[xp,yp]:=false
  114.  
  115.     end;
  116.     setcrsr(xko,yko);
  117.     write('X');
  118.     setcrsr(xko,yko);
  119.     until(c='w')
  120.     end;
  121.  
  122. procedure readbitm(var a:valfield;d:char);
  123.     
  124.     type chfile=file of char;
  125.  
  126.     var
  127.         offsa:integer;
  128.         dest:chfile;
  129.         k:integer;
  130.         result:integer;
  131.     
  132.     begin
  133.     offsa:=ord(d)*16+4096;
  134.     assign(dest,'characte.hlp');
  135.     reset(dest);
  136.     if ioresult=255 then
  137.         begin
  138.         write('    cannot read file    ! ');
  139.         exit
  140.         end;
  141.     for k:=0 to 7 do
  142.         begin
  143.         seekread(dest,offsa+k);
  144.         a[k+1]:=dest^
  145.         end;
  146.     close(dest,result);
  147.     if result=255 then
  148.         write(' error in closing of file ! ')
  149.     end;
  150.     
  151. procedure clear;
  152.     begin
  153.     write(chr(esc),':')
  154.     end;
  155.  
  156. procedure setcrsr(x,y:byte);
  157.     begin
  158.     write(chr(esc),'=',chr(y-1+32),chr(x-1+32))
  159.     end;    
  160.  
  161. function hexstr2(str:string):byte;
  162.     var wert:byte;
  163.     begin
  164.     wert:=0;
  165.     if (str[1]>='0')and(str[1]<='9')then
  166.         wert:=16*(ord(str[1])-ord('0'))
  167.     else
  168.         wert:=16*(ord(upper(str[1]))-ord('A')+10);
  169.     if (str[2]>='0')and(str[2]<='9')then
  170.         wert:=wert+ord(str[2])-ord('0')
  171.     else
  172.         wert:=wert+(10+ord(upper(str[2]))-ord('A'));
  173.     hexstr2:=wert
  174.     end;
  175.     
  176. procedure trval(var tab:valfield;gesetzt:edfield);
  177.     var   i,j:integer;
  178.               wert:byte;
  179.  
  180.     begin
  181.     for j:=1 to 8 do
  182.         begin
  183.         wert:=0;
  184.         for i:=1 to 8 do
  185.             begin
  186.             if (gesetzt[i,j]) then    
  187.                 wert:=wert+powers(2,i-1);
  188.             end;
  189.         tab[j]:=wert;
  190.         end
  191.     end;
  192.  
  193. procedure changef(tab:valfield;c:char);
  194.     type chfile=file of char;
  195.     var  result,k,offsa:integer;
  196.          dest:chfile;
  197.     begin
  198.     offsa:=(ord(c))*16+4096;
  199.     assign(dest,'characte.hlp');
  200.     reset(dest);
  201.     if ioresult=255 then
  202.         begin
  203.         setcrsr(5,20);
  204.         write('cannot open file ! ');
  205.         exit
  206.         end;
  207.     for k:=0 to 7 do
  208.         begin
  209.         dest^:=tab[k+1];
  210.         seekwrite(dest,offsa+k);
  211.         end;
  212.     close(dest,result);
  213.     if result=255 then
  214.         begin
  215.         setcrsr(5,21);
  216.         write('error in closing file  ! ')
  217.         end;
  218.     writeln;writeln;
  219.     end;
  220. procedure scrpicture;
  221.     begin
  222.     setcrsr(19,7);write('----------');
  223.     setcrsr(19,16);write('----------');
  224.     setcrsr(19,8);write('|');setcrsr(28,8);write('|');    
  225.     setcrsr(19,9);write('|');setcrsr(28,9);write('|');    
  226.      setcrsr(19,10);write('|');setcrsr(28,10);write('|');    
  227.     setcrsr(19,11);write('|');setcrsr(28,11);write('|');    
  228.     setcrsr(19,12);write('|');setcrsr(28,12);write('|');    
  229.     setcrsr(19,13);write('|');setcrsr(28,13);write('|');        
  230.     setcrsr(19,14);write('|');setcrsr(28,14);write('|');        
  231.     setcrsr(19,15);write('|');setcrsr(28,15);write('|');        
  232.     end;
  233.  
  234. procedure alter;
  235.     type crblock=array[0..35]of byte;
  236.     var flcbl:crblock;
  237.         value:integer;
  238.         gesetzt:edfield;
  239.         tab:valfield;
  240.         c:char;
  241.     begin
  242.     flcbl[0]:=0;flcbl[1]:=((ord('C')) & 127);flcbl[2]:=((ord('H')) & 127);
  243.     flcbl[3]:=((ord('A')) & 127);flcbl[4]:=((ord('R')) & 127);
  244.     flcbl[5]:=((ord('A')) & 127);flcbl[6]:=((ord('C')) & 127);
  245.     flcbl[7]:=((ord('T')) & 127);flcbl[8]:=((ord('E')) & 127);
  246.     flcbl[9]:=((ord('H')) & 127);flcbl[10]:=((ord('L')) & 127);
  247.     flcbl[11]:=((ord('P')) & 127);flcbl[12]:=0;flcbl[34]:=0;  
  248.     value:=@bdos(17,wrd(addr(flcbl)));
  249.     if value=255 then
  250.         begin
  251.             GrFOn;
  252.         GrFOff;
  253.         end;
  254.     repeat
  255.        editval(gesetzt,tab);
  256.        trval(tab,gesetzt);
  257.        changef(tab,buchst);
  258.        setcrsr(5,22);
  259.        write('change another character ? (y/n) ');
  260.        read(c);
  261.     until(c='n');
  262.     GrSOn;
  263.     GrFOff;
  264.     end;
  265.  
  266.     function powers(base,exponent:integer):integer;
  267.         var index,wert:integer;
  268.         begin
  269.         if exponent=0 then
  270.             begin
  271.             powers:=1;
  272.             end
  273.         else
  274.             begin
  275.             if exponent=1 then
  276.                 begin
  277.                 powers:=base;
  278.                 end
  279.             else
  280.                 begin
  281.                 wert:=base;
  282.                 for index:=2 to exponent do
  283.                     begin
  284.                     wert:=wert*base;
  285.                     end;
  286.                 powers:=wert;
  287.                 end
  288.             end
  289.         end;
  290.     
  291.     procedure oldone;
  292.         type crblock=array[0..35]of byte;
  293.         var flcbl:crblock;
  294.             value:integer;
  295.         begin
  296.     flcbl[0]:=0;flcbl[1]:=((ord('C')) & 127);flcbl[2]:=((ord('H')) & 127);
  297.     flcbl[3]:=((ord('A')) & 127);flcbl[4]:=((ord('R')) & 127);
  298.     flcbl[5]:=((ord('A')) & 127);flcbl[6]:=((ord('C')) & 127);
  299.     flcbl[7]:=((ord('T')) & 127);flcbl[8]:=((ord('E')) & 127);
  300.     flcbl[9]:=((ord('H')) & 127);flcbl[10]:=((ord('L')) & 127);
  301.     flcbl[11]:=((ord('P')) & 127);flcbl[12]:=0;flcbl[34]:=0;  
  302.         value:=@bdos(17,wrd(addr(flcbl)));
  303.         if value=255 then
  304.             begin
  305.             clear;writeln('no file  characte.hlp');
  306.             exit
  307.             end
  308.         else
  309.             GrSOn;
  310.             GrFOff;
  311.         end;
  312.  
  313.     procedure stopp;
  314.         var c:char;
  315.         begin
  316.         clear;writeln;writeln;
  317.         writeln('should file be written on boot-disk ? ');
  318.         repeat
  319.            read(c);
  320.         until ((c='J')or(c='j')or(c='N')or(c='n'));
  321.         if ((c='j')or(c='J')) then
  322.             begin
  323.             writeln;writeln;
  324.             writeln('insert boot-disk into drive a:  ');
  325.             write('ready ? ');
  326.             repeat
  327.                read(c);
  328.             until (c<>' ');
  329.             transform;
  330.             end
  331.         end;
  332.     procedure transform;
  333.         type chfile=file of char;
  334.              poac=array[1..2048]of char;
  335.         var source,dest:string;
  336.             quit:boolean;
  337.             a,b:chfile;
  338.             result,i:integer;
  339.             buf:poac;
  340.         begin
  341.         dest:='a:characte.hlp ';source:='characte.hlp ';
  342.         assign(a,source);
  343.         reset(a);
  344.         if ioresult=255 then
  345.             begin
  346.             writeln('cannot open file ',source);
  347.             exit
  348.             end;
  349.         open(b,'A:CHARACTE.HLP',result);
  350.             if result=255 then
  351.             begin
  352.             writeln('cannot open file ',dest);
  353.             exit
  354.             end;
  355.         i:=0;
  356.         repeat
  357.             blockread(a,buf,result,sizeof(buf),i);
  358.             if result=0 then
  359.                 begin
  360.                 blockwrite(b,buf,result,sizeof(buf),i);
  361.                 i:=i+sizeof(buf) div 128
  362.                 end
  363.             else
  364.                 quit:=true;
  365.         until quit;
  366.         close(b,result);
  367.         if result=255 then
  368.             writeln('cannot close file  ');
  369.     end;
  370.  
  371.  
  372. procedure GrFOn;
  373. var erg:integer;
  374.    begin
  375.    erg:=@bdos (153,wrd(0));
  376.    end;
  377.  
  378. function upper(a:char):char;
  379.     begin
  380.     if (ord(a)>=97)and(ord(a)<=122)then
  381.         upper:=chr(ord(a)-32)
  382.     else
  383.         upper:=a
  384.     end;
  385.  
  386. procedure GrSOn;
  387. var erg:integer;
  388.    begin
  389.    erg:=@bdos (154,wrd(0));
  390.    end;
  391.  
  392. procedure GrFOff;
  393.    var erg:integer;
  394.    begin
  395.    erg:=@bdos (155,wrd(0));
  396.    end;
  397.  
  398. procedure auswahl;
  399.     var
  400.          cond1,cond2,cond3,cond4,cond5,cond6,cond7,cond8:boolean;
  401.     begin
  402.     clear;
  403.     setcrsr(10,5);
  404.     write('        1)    ASCII         value        ');
  405.     setcrsr(10,9);
  406.     write('        2)    HEX        value        ');
  407.     setcrsr(10,12);
  408.     write('        Ihre Wahl  : ');
  409.     repeat
  410.         setcrsr(32,12);
  411.         read(c);
  412.         if (c<>'1')or(c<>'2')then
  413.             begin
  414.             setcrsr(32,12);
  415.             write(' ');
  416.             setcrsr(32,12)
  417.             end;
  418.     until (c='1')or(c='2');
  419.     setcrsr(10,15);
  420.     write('    character : ');
  421.     case c of
  422. '1':    begin
  423.       setcrsr(22,15);
  424.       read (d)
  425.     end;
  426. '2':    begin
  427.     repeat
  428.         setcrsr(22,15);
  429.         write('  ');
  430.         setcrsr(22,15);
  431.         read(str);
  432.         cond1:=(str[1]>='0')and(str[1]<='9');
  433.         cond2:=(str[1]>='a')and(str[1]<='f');
  434.         cond3:=(str[1]>='A')and(str[1]<='F');
  435.         cond4:=(str[2]>='0')and(str[2]<='9');
  436.         cond5:=(str[2]>='a')and(str[2]<='f');
  437.         cond6:=(str[2]>='A')and(str[2]<='F');
  438.         cond7:=cond1 or cond2 or cond3;
  439.         cond8:=cond4 or cond5 or cond6;
  440.     until ((length(str)=2)and(cond7 and cond8));
  441.     end
  442.     end;
  443.     if c='2' then
  444.         d:=chr(hexstr2(str));
  445.     buchst:=d;
  446.     clear;
  447.     setcrsr(10,3);
  448.     write('        1)    start with empty character bit map    ');
  449.     setcrsr(10,7);
  450.     write('        2)    start with old character bit map    ');
  451.     setcrsr(10,9);
  452.     write('        choose    :    ');
  453.     repeat
  454.         setcrsr(43,9);
  455.         read(c);
  456.         if (c<>'1')or(c<>'2')then
  457.             begin
  458.             setcrsr(43,9);
  459.             write('  ')
  460.             end;
  461.     until (c='1')or(c='2');
  462.     end;
  463.  
  464. procedure wrtext;
  465.  
  466.     begin
  467.     clear;
  468.     setcrsr(5,2);write(' s .. left ');
  469.     setcrsr(5,3);write(' d .. right ');
  470.     setcrsr(5,4);write(' e .. up ');    
  471.     setcrsr(5,5);write(' x .. down ');
  472.     setcrsr(5,6);write(' q .. define ');
  473.     setcrsr(5,7);write(' r .. delete ');
  474.     setcrsr(5,8);write(' w .. save ');
  475.     end;
  476.  
  477.     
  478.     begin
  479.     repeat
  480.     clear;
  481.     writeln;writeln;
  482.     write('changing the character set ');
  483.     writeln;writeln;
  484.     writeln('    1.)    read in the old character set ');
  485.     writeln;writeln;
  486.     writeln('    2.)    change the character set ');
  487.     writeln;writeln;
  488.     writeln('    3.)    exit to CP/M    ');
  489.     writeln;writeln;
  490.     write('choose : ');
  491.     repeat
  492.        read(c);
  493.     until((c='1')or(c='2')or(c='3'));
  494.     case c of
  495.     '1':oldone;
  496.     '2':alter;
  497.     '3':stopp;
  498.     end;
  499.     until (c='3');
  500.     end.
  501.  
  502.  
  503.