home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 08 / grafkurs / fontedit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-06-01  |  8.5 KB  |  239 lines
  1. (*-------------------------------------------------------------------------*)
  2. (*                              FONTEDIT.PAS                               *)
  3. (*                  Editieren von Fonts der Grafikserie                    *)
  4. (*-------------------------------------------------------------------------*)
  5.  
  6. PROGRAM FontEditor;
  7.  
  8. CONST (*$I GRAFCONS.PAS *)
  9.             (*** Kostanten der Editor-Bedienung: ***)
  10.       LeftKey   = 'S';         (* Eins nach links  *)
  11.       RightKey  = 'D';         (* Eins nach links  *)
  12.       UpKey     = 'E';         (* Eins nach links  *)
  13.       DownKey   = 'X';         (* Eins nach links  *)
  14.       FillKey   = ' ';         (* Pixel fuellen    *)
  15.       DeleteKey = '-';         (* Pixel loeschen   *)
  16.       QuitKey   = 'Q';         (* Editor verlassen *)
  17.  
  18. TYPE (*$I GRAFTYPE.PAS *)
  19.      TInput = (MoveLeft, MoveRight, MoveUp, MoveDown, FillPix, DelPix, Quit);
  20.  
  21. VAR (*$I GRAFVAR.PAS *)
  22.     EndEdit, PosX, PosY, ZeichenNr,
  23.     AnfangX, AnfangY, Breite,
  24.     Hoehe, Steph, Stepw, Left : INTEGER;
  25.     FontFile : FILE OF TFont;
  26.     Infile, Outfile : STRING[255];
  27.  
  28. (*$I GRAPH.P      *)
  29. (*$I GRAFSYS.PAS  *)
  30. (*$I INTDDA.PAS   *)
  31. (*$I LINE.PAS     *)
  32. (*$I BRESENH.PAS  *)
  33. (*$I CIRCLE.PAS   *)
  34. (*-------------------------------------------------------------------------*)
  35. (*         Ein Zeichen direkt ohne Echo von der Tastatur lesen             *)
  36. FUNCTION GetCh : CHAR;
  37.  
  38. VAR Zeichen : CHAR;
  39.  
  40. BEGIN
  41.   REPEAT UNTIL KeyPressed;
  42.   Read(Kbd,Zeichen);  GetCh := UpCase(Zeichen)
  43. END;
  44. (*-------------------------------------------------------------------------*)
  45. (*      Masse der Darstellungsmatrix fuer den Bildschirm berechnen         *)
  46. PROCEDURE BerechneMatrix;
  47.  
  48. BEGIN
  49.   AnfangY := Round(0.25 * ScreenYMax);  AnfangX := Round(0.25 * ScreenXMax);
  50.   Breite := 8 * Round(ScreenXMax/32);   Hoehe := 8 * Round(ScreenYMax/16);
  51.   Steph := Round(ScreenYMax/16);        Stepw := Round(ScreenXMax/32)
  52. END;
  53. (*-------------------------------------------------------------------------*)
  54. (*                Zeichen-Matrix auf den Bildschirm "malen"                *)
  55. PROCEDURE PutCell (Cell : TCell);
  56.  
  57. VAR x, y, i, j : INTEGER;
  58.  
  59. BEGIN
  60.   x := AnfangX + Breite * 3 DIV 2;   y := AnfangY + Hoehe DIV 2;
  61.   FOR i := 0 TO CellSize DO
  62.     FOR j := 0 TO CellSize DO
  63.       BEGIN
  64.         IF Cell[j,i] THEN set_Pen_Color(Last_Color_Value)
  65.         ELSE set_Pen_Color(First_Color_Value);
  66.         point(x+i,y+j)
  67.       END;
  68.   set_Pen_Color(Last_Color_Value); Circle(x+3,y+3,15)
  69. END;
  70. (*-------------------------------------------------------------------------*)
  71. (*                    Matrix-Gitter auf den Schirm malen                   *)
  72. PROCEDURE DrawGrid;
  73.  
  74. VAR i : INTEGER;
  75.  
  76. BEGIN
  77.   FOR i := 0 TO CellSize + 1 DO
  78.     BEGIN
  79.       Line(AnfangX, AnfangY+i*Steph, AnfangX+Breite, AnfangY+i*Steph);
  80.       Line(AnfangX+i*Stepw, AnfangY, AnfangX+i*Stepw, AnfangY+Hoehe)
  81.     END
  82. END;
  83. (*-------------------------------------------------------------------------*)
  84. (*                              Cursor "malen"                             *)
  85. PROCEDURE SetCursor (Zeile, Spalte : INTEGER);
  86.  
  87. VAR Radius, x, y : INTEGER;
  88.  
  89. BEGIN
  90.   set_Pen_Color(Last_Color_Value);   Radius := (Stepw-1) DIV 2;
  91.   x := AnfangX + Spalte*Stepw + Stepw DIV 2;
  92.   y := AnfangY + Zeile*Steph + Steph DIV 2;
  93.   Circle(x,y,Radius)
  94. END;
  95. (*-------------------------------------------------------------------------*)
  96. (*                    "Gemalten" Cursor wieder entfernen                   *)
  97. PROCEDURE RemoveCursor (Zeile, Spalte : INTEGER);
  98.  
  99. VAR Radius, x, y : INTEGER;
  100.  
  101. BEGIN
  102.   set_Pen_Color(First_Color_Value);  Radius := (Stepw-1) DIV 2;
  103.   x := AnfangX + Spalte*Stepw + Stepw DIV 2;
  104.   y := AnfangY + Zeile*Steph + Steph DIV 2;
  105.   Circle(x,y,Radius)
  106. END;
  107. (*-------------------------------------------------------------------------*)
  108. (*              Cursorposition mit einem "fetten" Punkt fuellen            *)
  109. PROCEDURE FillPixel (Zeile, Spalte : INTEGER);
  110.  
  111. VAR Radius, x, y, i : INTEGER;
  112.  
  113. BEGIN
  114.   set_Pen_Color(Last_Color_Value);  Radius := ((Stepw-1) DIV 2) - 3;
  115.   x := AnfangX + Spalte*Stepw + Stepw DIV 2;
  116.   y := AnfangY + Zeile*Steph + Steph DIV 2;
  117.   FOR i := 0 TO Radius DO  Circle(x,y,i)
  118. END;
  119. (*-------------------------------------------------------------------------*)
  120. (*                       Fetten Punkt wieder entfernen                     *)
  121. PROCEDURE DeletePixel(Zeile, Spalte : INTEGER);
  122.  
  123. VAR Radius, x, y, i : INTEGER;
  124.  
  125. BEGIN
  126.   set_Pen_Color(First_Color_Value);  Radius := ((Stepw-1) DIV 2) - 3;
  127.   x := AnfangX + Spalte*Stepw + Stepw DIV 2;
  128.   y := AnfangY + Zeile*Steph + Steph DIV 2;
  129.   FOR i := 0 TO Radius DO  Circle(x,y,i)
  130. END;
  131. (*-------------------------------------------------------------------------*)
  132. (*              Tastendruecke des Benutzer in "Symbole" umsetzen           *)
  133. FUNCTION GetUserInput : TInput;
  134.  
  135. VAR Zeichen : CHAR;
  136.  
  137. BEGIN
  138.   REPEAT
  139.     Zeichen := GetCh
  140.   UNTIL Zeichen IN[LeftKey,RightKey,UpKey,DownKey,FillKey,DeleteKey,QuitKey];
  141.   CASE Zeichen OF
  142.       LeftKey : GetUserInput := MoveLeft;
  143.      RightKey : GetUserInput := MoveRight;
  144.         UpKey : GetUserInput := MoveUp;
  145.       DownKey : GetUserInput := MoveDown;
  146.       FillKey : GetUserInput := FillPix;
  147.     DeleteKey : GetUserInput := DelPix;
  148.       QuitKey : GetUserInput := Quit
  149.   END
  150. END;
  151. (*-------------------------------------------------------------------------*)
  152. PROCEDURE EditCell (VAR Cell : TCell);
  153.  
  154. VAR UserInp : TInput;
  155.     PosX, PosY, AltPosX, AltPosY : INTEGER;
  156.     changed : BOOLEAN;
  157.  
  158. BEGIN
  159.   FOR PosX := 0 TO CellSize DO
  160.     FOR PosY := 0 TO CellSize DO
  161.       IF Cell[PosY,PosX] THEN  FillPixel(PosY,PosX);
  162.   PutCell(Cell);  PosX := 0;  PosY := 0;  changed := FALSE;
  163.   REPEAT
  164.     AltPosX := PosX;  AltPosY := PosY;  SetCursor(PosY,PosX);
  165.     UserInp := GetUserInput;
  166.     CASE UserInp OF
  167.        MoveLeft : BEGIN
  168.                     PosX := Pred(PosX);
  169.                     IF PosX < 0 THEN
  170.                       BEGIN
  171.                         PosX := 7;  PosY := Pred(PosY);
  172.                         IF PosY < 0 THEN
  173.                           BEGIN  PosY := 0;  PosX := 0  END
  174.                       END
  175.                   END;
  176.       MoveRight : BEGIN
  177.                     PosX := Succ(PosX);
  178.                     IF PosX > 7 THEN
  179.                       BEGIN
  180.                         PosX := 0;  PosY := Succ(PosY);
  181.                         IF PosY > 7 THEN
  182.                           BEGIN  PosY := 7;  PosX := 7  END
  183.                       END
  184.                   END;
  185.          MoveUp : BEGIN
  186.                     PosY := Succ(PosY); IF PosY > 7 THEN  PosY := 7
  187.                   END;
  188.        MoveDown : BEGIN
  189.                     PosY := Pred(PosY); IF PosY < 0 THEN  PosY := 0
  190.                   END;
  191.         FillPix : BEGIN
  192.                     Cell[PosY,PosX] := TRUE;
  193.                     FillPixel(PosY,PosX);
  194.                     changed := TRUE
  195.                   END;
  196.          DelPix : BEGIN
  197.                     Cell[PosY,PosX] := FALSE;
  198.                     DeletePixel(PosY,PosX);
  199.                     changed := TRUE;
  200.                   END;
  201.          Quit : ;
  202.     END; (* CASE UserInp *)
  203.     RemoveCursor(AltPosY,AltPosX);
  204.     IF changed THEN  BEGIN  PutCell(Cell);  changed := FALSE   END;
  205.   UNTIL UserInp = Quit
  206. END;
  207. (*-------------------------------------------------------------------------*)
  208. BEGIN
  209.   EndEdit := CellMax + 1;  ClrScr;                  (* Bildschirm loeschen *)
  210.   WriteLn('                            Font Editor');
  211.   WriteLn('                            -----------');
  212.   WriteLn; WriteLn; WriteLn;
  213.   Write('Name des Zeichensatzes (RETURN fuer neuen): '); ReadLn(Infile);
  214.   WriteLn;  Write('Unter welchem Namen speichern: '); ReadLn(Outfile);
  215.   IF Length(Infile) > 0 THEN
  216.     BEGIN
  217.       Assign(FontFile,Infile+'.FNT');
  218.       ReSet(FontFile);   Read(FontFile,Font);   Close(FontFile);
  219.     END
  220.   ELSE
  221.     FOR ZeichenNr := CellMin TO CellMax DO
  222.       FOR Breite := 0 TO CellSize DO
  223.         FOR Hoehe := 0 TO CellSize DO Font[ZeichenNr,Breite,Hoehe] := FALSE;
  224.   REPEAT
  225.     ClrScr; WriteLn; WriteLn; WriteLn;
  226.     Write('Nummer des zu editierenden Buchstaben (Ende mit ',EndEdit,'): ');
  227.     ReadLn(ZeichenNr);
  228.     IF ZeichenNr <> EndEdit THEN
  229.       BEGIN
  230.         Enter_Graphic;  BerechneMatrix;  DrawGrid;
  231.         EditCell(Font[ZeichenNr]);  Exit_Graphic
  232.       END
  233.   UNTIL ZeichenNr = EndEdit;
  234.   ClrScr;  WriteLn; WriteLn; WriteLn;
  235.   Write('Font wird als ',Outfile,' gesichert.');
  236.   Assign(FontFile,Outfile+'.FNT');
  237.   ReWrite(FontFile);  Write(FontFile,Font);  Close(FontFile)
  238. END.
  239.