home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS1.3 / Banner.p < prev    next >
Encoding:
Text File  |  1994-07-23  |  14.3 KB  |  437 lines
  1. {                                                                       }
  2. { BANNER                                                                }
  3. { ------                                                                }
  4. {                                                                       }
  5. { Ein Programm zur Papier- und Farbbandverschwendung.                   }
  6. {                                                                       }
  7. { Mit diesem Programm kann man meterlange Spruchbänder drucken.         }
  8. { Die Parameter werden vom CLI übergeben. Syntax:                       }
  9. {                                                                       }
  10. {  Banner { -v|-h|-cN|-xN|-yN|-rZ|+FONTNAME } TEXT                      }
  11. {                                                                       }
  12. { Die verschiedenen Parameter haben dabei folgende Bedeutung:           }
  13. {                                                                       }
  14. { -v  : vertikale Ausgabe (die Schrift läuft von oben nach unten        }
  15. { -h  : horizontale Ausgabe (zeilenweise)                               }
  16. {       Standardeinstellung ist "h" bei Zeichensätzen bis 15 Punkten    }
  17. {       Höhe und "v" ab 16 Punkten Schrifthöhe.                         }
  18. { -cN : (Center) Der Text ist horizontal und auf "N" Spalten zentriert  }
  19. {       auszugeben.                                                     }
  20. { -xN : Jeder Punkt des Zeichensatzes soll bei der Ausgabe "N" Sternchen}
  21. {       breit ausgedruckt werden.                                       }
  22. { -yN : Jeder Punkt des Zeichensatzes soll "N" Sterne hoch ausgegeben   }
  23. {       werden.                                                         }
  24. {       Standardeinstellung:    -x1 -y1  bei horizontaler Shcrift       }
  25. {                               -x3 -y1  bei vertokaler Ausgabe         }
  26. { -rZ : links ist ein "Z" Spalten breiter Rand zu lassen. Der Rand kann }
  27. {       auch negativ sein: dann werden die ersten "-Z" Zeichen jeder    }
  28. {       Zeile weggelassen.                                              }
  29. { +FONTNAME : Der enstprechende Amiga-Systemzeichensatz wird verwendet. }
  30. {       Beispiel: +Ruby15  benutzt den "Ruby.font" mit 15 Punkten Höhe. }
  31. {       Standardeinstellung ist "+topaz9".                              }
  32. { TEXT: Der Text, der auszugeben ist. Bei horizontaler Ausgabe können   }
  33. {       dabei mehrere Zeilen durch "\" getrennt werden.                 }
  34. {                                                                       }
  35. { Beispiele:                                                            }
  36. {                                                                       }
  37. { Banner Hallo                                                          }
  38. {  Ergebnis:                                                            }
  39. {  **   **              ***       ***                                   }
  40. {  **   **               **        **                                   }
  41. {  **   **   *****       **        **       *****                       }
  42. {  *******       **      **        **      **   **                      }
  43. {  **   **    *****      **        **      **   **                      }
  44. {  **   **  **   **      **        **      **   **                      }
  45. {  **   **   **** **    ****      ****      *****                       }
  46. {                                                                       }
  47. { Banner -v -x8 -y5 Hallo                                               }
  48. {  Der normale Topaz9-Font wird so vergrößert, daß er bei senkrechter   }
  49. {  Textausgabe den ganzen Bildschirm ausfüllt.                          }
  50. {                                                                       }
  51. { Banner +ruby15 -c77 Du\mich\auch!                                     }
  52. {  In drei zentrierten Zeilen wird der Text "Du mich auch!" mit dem     }
  53. {  Ruby15-Zeichensatz ausgegeben.                                       }
  54. {                                                                       }
  55. { Banner +emerald20 -r-5 Horrido!                                       }
  56. {  Es wird der Emerald20-Font benutzt. Durch die Höhe 20 wird           }
  57. {  automatisch senkrecht geschrieben. Dabei werden ("negativer Rand")   }
  58. {  die ersten 5 Spalten weggelassen, da sie eh' nur Spaces enthalten.   }
  59. {                                                                       }
  60. { Übrigens erfolgt die Ausgabe normalerweise auf dem Bildschirm. Wenn   }
  61. { Sie das Banner drucken wollen, müssen Sie es mit "Banner >prt: ..."   }
  62. { zum Printer schicken.                                                 }
  63.  
  64. { Written by Jens "Himpel" Gelhar Oct/Nov. 89 }
  65.  
  66. { MaxonPascal3-Anpassung: Falk Zühlsdorff (PackMAN) 1994 }
  67.  
  68.  
  69. Program banner;
  70. USES Graphics;
  71. {$incl 'diskfont.lib'}
  72.  
  73. Label 99;             { Anmerkung: in MP3/KP ist die Goto-Anweisung zu
  74.                                    vermeiden, will nur Programm nicht
  75.                                    total umschreiben, PackMAN          }
  76. Const
  77.   Trenn = '\';
  78.  
  79. Type
  80.   CLocType = Array [0..255] of Record offset, breite:Word End;
  81.   SpaceType = Array[0..255] of integer;
  82.   strtype = String[200];
  83.  
  84. Var
  85.   fnt: p_TextFont;      { Zeiger auf Font-Struktur }
  86.   txat: TextAttr;       { Text-Attribut-Struktur für "OpenDiskFont" }
  87.   YSize: integer;       { Zeichensatzhöhe }
  88.   Fontname: string[50]; { Zeichensatzname }
  89.   i, j: integer;
  90.   Punktbreite, Punkthoehe: integer;   { "Vergrößerung" }
  91.   tx: string[300];                    { Puffer für ParameterString }
  92.   err, VertFlag, HorizFlag, CenterFlag: Boolean;
  93.   Ausgabe: strtype;
  94.   HiChar, LoChar: char;
  95.   CharData: Long;       { Bitplane-Adresse }
  96.   Offset, Width, Kern, Space: Array[Char] of integer;
  97.   Modulo, Rand: integer;
  98.   Zeilenlaeng: integer;
  99.   buf: String[257];     { Puffer für Ausgabe }
  100.  
  101.  
  102. Procedure InitVars;
  103.  { Nach "OpenDiskFont" diverse Variablen aufgrund von Feldern }
  104.  { der Font-Struktur initialisieren                           }
  105.  Var
  106.   clp: ^CLocType;
  107.   krp,spp: ^SpaceType;
  108.   i: integer;
  109.   c: Char;
  110.  Begin
  111.   LoChar := chr(fnt^.tf_LoChar);
  112.   HiChar := chr(fnt^.tf_HiChar);
  113.   Modulo := fnt^.tf_Modulo;
  114.   CharData := Long(fnt^.tf_CharData);
  115.   clp := fnt^.tf_CharLoc;
  116.   krp := fnt^.tf_CharKern;
  117.   spp := fnt^.tf_CharSpace;
  118.   For c:=chr(0) to chr(MaxByte) do   { Defaultwerte für Bereich }
  119.     Begin                            { außerhalb LoChar..HiChar }
  120.       Offset[c]:= 0;
  121.       Width[c] := 0;
  122.       Space[c] := fnt^.tf_xsize;
  123.       Kern[c]  := 0
  124.     End;
  125.   For c:=LoChar to HiChar Do { wegen schnelleren Zugriffs Daten }
  126.     Begin                    { aus der Font-Struktur in Arrays kopieren }
  127.       Offset[c] := clp^[ord(c)-ord(LoChar)].offset;
  128.       Width [c] := clp^[ord(c)-ord(LoChar)].breite;
  129.       If krp=Nil Then
  130.         Kern[c] := 0
  131.       Else
  132.         Kern[c] := krp^[ord(c)-ord(LoChar)];
  133.       If spp=Nil Then
  134.         Space[c] := fnt^.tf_XSize
  135.       Else
  136.         Space[c] := spp^[ord(c)-ord(LoChar)];
  137.     End;
  138.   YSize := fnt^.tf_YSize
  139.  End;
  140.  
  141.  
  142. Function Dot(ch: char; x,y: integer): Boolean;
  143.   { prüft, ob Punkt (x,y) im Zeichen "ch" des aktuellen Fonts }
  144.   { gesetzt ist.                                              }
  145.   Var
  146.     Adr: Long;
  147.     Schleif, Off: integer;
  148.   Begin
  149.     If x < kern[ch] Then
  150.       Dot:=false
  151.     Else
  152.       Begin
  153.         If x >= Width[ch]+kern[ch] Then
  154.           Dot:=false
  155.         Else
  156.           Begin
  157.             Off := offset[ch] - kern[ch] + x;
  158.             Adr := CharData + y * Modulo + Off div 8;
  159.             Dot := (Mem[Adr] and ($80 shr (Off mod 8))) <> 0
  160.           End;
  161.       End
  162.   End;
  163.  
  164.  
  165. Procedure Aus(k: integer);
  166.   { String "buf" mit Rand und ohne überflüssige }
  167.   { Leerzeichen am Ende "k"-mal ausgeben        }
  168.   Var i, j: integer;
  169.   Begin
  170.     If Rand<0 Then
  171.       For i:=1 to StrLen(buf)+Rand+1 do buf[i]:=buf[i-Rand];
  172.     i:=Length(buf);
  173.     While (i>1) and (buf[i]=' ') Do i:=pred(i);
  174.     If buf[i]=' ' Then buf[i]  :=chr(0)
  175.                   Else buf[i+1]:=chr(0);
  176.     For j:=1 to k Do
  177.       Begin
  178.         If break(1) Then      { Ctrl-C? Dann geordneter Ausstieg. }
  179.           Begin
  180.             writeln('^C');
  181.             Goto 99
  182.           End;
  183.         If Rand>0 Then write('': Rand);
  184.         writeln(buf)
  185.       End
  186.   End;
  187.  
  188. Procedure Horizontal(s: strtype);
  189.   { waagerechte Ausgabe }
  190.   Var x, y, i, j, i0, x1, y1: integer;
  191.       breite, Pos0, t: integer;
  192.       c: char;
  193.   Begin
  194.     i0 := 1;
  195.     While s[i0] >= ' ' Do
  196.      Begin
  197.       breite:=0;
  198.       i:=i0;
  199.       While (s[i]>=' ') and (s[i]<>Trenn) Do
  200.         Begin
  201.           breite := breite + Punktbreite*space[s[i]];
  202.           i := i+1
  203.         End;
  204.  
  205.       If breite > 256 Then
  206.         Begin
  207.           writeln('Maximum lenght of line is 256');
  208.           goto 99
  209.         End;
  210.  
  211.       If Centerflag Then Pos0 := (Zeilenlaeng-breite) div 2
  212.                     Else Pos0 := 0;
  213.       For y:=0 To YSize-1 Do
  214.         Begin
  215.           i:=i0;
  216.           t:=1;
  217.           For j:=1 To Pos0 Do
  218.             Begin
  219.               buf[t] := ' ';
  220.               t := t+1
  221.             End;
  222.           While (s[i] >= ' ') and (s[i] <> Trenn) Do
  223.             Begin
  224.               c := s[i];
  225.               If (c < LoChar) or (c > HiChar) Then c:=' ';
  226.               For x:=0 To space[c]-1 Do
  227.                 If Dot(c,x,y) Then
  228.                   For x1:=1 To Punktbreite Do
  229.                     Begin
  230.                       buf[t]:='*';
  231.                       t:=succ(t)
  232.                     End
  233.                  Else
  234.                   For x1:=1 To Punktbreite Do
  235.                     Begin
  236.                       buf[t]:=' ';
  237.                       t:=succ(t)
  238.                     End;
  239.               i:=i+1
  240.             End;
  241.           buf[t]:=chr(0);
  242.           Aus(PunktHoehe)
  243.         End;
  244.       i0 := i;
  245.       If s[i] = Trenn Then i0 := i0+1
  246.      End;
  247.   End;
  248.  
  249.  
  250. Procedure Vertikal(s: strtype);
  251.   Var x, y, i, t, x1, y1: integer;
  252.       c: char;
  253.   Begin
  254.     i:=1;
  255.     While s[i] >= ' ' Do
  256.       Begin
  257.         c := s[i];
  258.         If (c < LoChar) or (c > HiChar) Then c:=' ';
  259.         For x:=0 to Space[c]-1 Do
  260.           Begin
  261.             t:=1;
  262.             For y:=YSize-1 Downto 0 Do
  263.               If Dot(c,x,y) Then
  264.                 For y1:=1 To Punktbreite Do
  265.                   Begin buf[t]:='*'; t:=succ(t) End
  266.                Else
  267.                 For y1:=1 To Punktbreite Do
  268.                   Begin buf[t]:=' '; t:=succ(t) End;
  269.              buf[t]:=chr(0);
  270.              Aus(PunktHoehe)
  271.           End
  272.         i:=i+1
  273.       End;
  274.   End;
  275.  
  276.  
  277. Function Digit(ch: Char): integer;
  278.   { testen, ob Zeichen "ch" Ziffer ist, und Wert zurückgeben }
  279.   Begin
  280.     If ch in ['0'..'9'] Then
  281.       Digit := ord(ch)-ord('0')
  282.     Else
  283.       Digit := -1
  284.   End;
  285.  
  286.  
  287. Procedure Info;
  288.   { Info-Text ausbannern }
  289.   Begin
  290.     txat := TextAttr('topaz.font', 9, 0, 0);
  291.     fnt := OpenDiskFont(^txat);
  292.     If fnt=Nil Then
  293.       error('Font nicht gefunden!');
  294.     InitVars;
  295.     Punktbreite:=1;
  296.     Punkthoehe:=1;
  297.     Centerflag := true;
  298.     Zeilenlaeng:=77;
  299.     write(''\n\e'33m');
  300.     Horizontal('Banner');
  301.     write(''\e'31m'\n);
  302.     Horizontal('Written\by:\Jens\Gelhar\1989')
  303.   End;
  304.  
  305.  
  306. Begin
  307.   OpenLib(DiskFontBase, 'diskfont.library', 0);
  308.   OpenLib(GfxBase, 'graphics.library', 0);
  309.  
  310.   YSize := 9;
  311.   Fontname := 'topaz.font';     { Defaultfont und -höhe }
  312.   Punktbreite := 0;
  313.   Punkthoehe := 0;
  314.   Rand := 0;
  315.   tx := parameterstr;
  316.   tx[parameterlen+1] := chr(0);
  317.   i := 1;
  318.   VertFlag := false;
  319.   Horizflag := false;
  320.   Centerflag := false;
  321.   While tx[i]=' ' Do i:=succ(i);
  322.   err:= tx[i]<' ';
  323.   While ((tx[i]=' ') or (tx[i]='-') or (tx[i]='+')) and not err Do
  324.     { Optionen auswerten }
  325.     Begin
  326.       If tx[i]='+' Then
  327.         Begin
  328.           j:=1; i:=i+1;
  329.           While tx [i] >= 'A' Do
  330.             Begin
  331.               Fontname[j] := tx[i];
  332.               i := i+1;
  333.               j := j+1
  334.              End;
  335.            fontname[j] := chr(0);
  336.            If fontname='' Then err:=true;
  337.            fontname:=fontname + '.font';
  338.            YSize:=Digit(tx[i]);
  339.            If YSize<0 Then err:=true
  340.            Else
  341.              If Digit(tx[i+1]) >= 0 Then
  342.                Begin
  343.                  i := i+1;
  344.                  YSize := 10*YSize + digit(tx[i])
  345.                End;
  346.           If not(Vertflag or Horizflag) Then
  347.             Begin
  348.               Vertflag:= YSize>16;
  349.               Horizflag := not Vertflag
  350.             End;
  351.         End;
  352.       If tx[i]='-' Then
  353.         Begin
  354.           i:=i+1;
  355.           Case tx[i] Of
  356.           'v': VertFlag:=true;
  357.           'h': VertFlag:=false;
  358.           'x': Begin i:=i+1; PunktBreite:=Digit(tx[i]);
  359.                      err := Punktbreite<0
  360.                End;
  361.           'y': Begin i:=i+1; PunktHoehe:=Digit(tx[i]);
  362.                      err := Punkthoehe<0
  363.                End;
  364.           'r': Begin i := i+1;
  365.                      If tx[i]='-' Then
  366.                        Begin
  367.                          i:=i+1; j:=-1
  368.                        End
  369.                      Else j:=1;
  370.                      Rand:=Digit(tx[i]);
  371.                      If Rand<=0 Then err:=true
  372.                      Else
  373.                        While Digit(tx[i+1])>=0 Do
  374.                          Begin
  375.                            i:=i+1; Rand:=10*Rand+Digit(tx[i])
  376.                          End;
  377.                      Rand := j*Rand; { Vorzeichen }
  378.                End;
  379.           'c': Begin
  380.                  i := i+1;
  381.                  Zeilenlaeng := Digit(tx[i]);
  382.                  If Zeilenlaeng <= 0 Then err:=true
  383.                  Else
  384.                  While Digit(tx[i+1]) >= 0 Do
  385.                    Begin
  386.                      i:=i+1; Zeilenlaeng := 10*Zeilenlaeng + Digit(tx[i])
  387.                    End;
  388.                  Centerflag := true;
  389.                  Horizflag := true;
  390.                  Vertflag := false;
  391.                  If Zeilenlaeng > 256 Then
  392.                    Error('Maximum lenght of line is 256')
  393.                End;
  394.           '?': Info;
  395.           Otherwise
  396.             err:=true
  397.           End
  398.         End;
  399.       i := i+1
  400.     End;
  401.  
  402.   Ausgabe:=Copy(tx,i,Length(tx)-i+1);  { Rest ist auszugeben }
  403.  
  404.   If err Then
  405.     Error('Usage: Banner { -v|-h|-cN|-xN|-yN|-rZ|+FONTNAME } TEXT'\n' Info: Banner -?');
  406.  
  407.   If Punktbreite=0 Then             { Defaultwerte: }
  408.     If VertFlag Then Punktbreite := 3
  409.                 Else Punktbreite := 1;
  410.  
  411.   If Punkthoehe=0 Then Punkthoehe:= 1;
  412.  
  413.   txat := TextAttr(Fontname, YSize, 0, 0);
  414.   fnt := OpenDiskFont(^txat);       { Zeichensatz laden }
  415.   If fnt=Nil Then
  416.     error('Font nicht gefunden!');
  417.   InitVars;
  418.  
  419.   If Vertflag and (YSize*Punktbreite>256) Then
  420.     Begin
  421.       CloseFont(fnt);
  422.       Error('Maximum lenght of line is 256')
  423.     End;
  424.  
  425.   If VertFlag Then
  426.     Vertikal(Ausgabe)
  427.   Else
  428.     Horizontal(Ausgabe)
  429.  
  430. 99:
  431.   CloseFont(fnt);
  432.   CloseLib(GfxBase);
  433.   CloseLib(DiskFontBase)
  434. End.
  435.  
  436.  
  437.