home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1987 / 12 / sharpgrf.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-09-07  |  10.7 KB  |  239 lines
  1. (* ----------------------------------------------------------------------- *)
  2. (*                              SHARPGRF.PAS                               *)
  3. (*                Grafik  auf dem Sharp MZ800 mit Turbo Pascal             *)
  4. (*               Bruno Volkmer 1987,   fuer  PASCAL INTERNATIONAL          *)
  5.  
  6. TYPE  graf_code = ARRAY[1..11] OF BYTE;
  7.  
  8. CONST                                               (* Maschinen-Routinen: *)
  9.       toVideo   : graf_code = ($f3,$47,$db,$e0,$d3,$e0,$70,$db,$e1,$fb,$c9);
  10.       fromVideo : graf_code = ($f3,$db,$e0,$d3,$e0,$46,$db,$e1,$78,$fb,$c9);
  11.       copyVideo : graf_code = ($f3,$db,$e0,$ed,$b0,$db,$e1,$fb,$c9,  0,  0);
  12.  
  13.       PALPort    = $f0;              (* verantwortlich  fuer die Farbe     *)
  14.       ModePort   = $ce;              (* Bildschirmaufloesung               *)
  15.       ReadPort   = $cd;              (* von welcher Bildebene wird gelesen *)
  16.       WritePort  = $cc;              (* in welche Ebene wird geschrieben   *)
  17.                                      (* und wie werden Werte verknuepft    *)
  18.       ScreenXmax = 639;
  19.       ScreenYmax = 191;                 (* wegen der Statuszeile 200-8     *)
  20.       VideoBegin = $8000;               (* Adresse des Videorams           *)
  21.       VideoRAM   = $4000;               (* Groesse des  Videorams, 16kB    *)
  22.       VideoSize  = 2048;                (* Buffer zum Speichern des Bildes *)
  23.  
  24. TYPE MaxColor    = 0..15;
  25.      SysColors   = (Black, Blue, Red, Magenta, Green, Cyan, Brown,
  26.                     LightGray, DarkGray, LightBlue, LightRed, LightMagenta,
  27.                     LightGreen, LightCyan, Yellow, White);
  28.      PicName     = STRING [14];
  29.      Planes      = 0..3;
  30.  
  31. VAR
  32.    VideoIn      : graf_code ABSOLUTE $130;         (* Lage der Umleitungen *)
  33.    VideoOut     : graf_code ABSOLUTE $140;
  34.    VideoCop     : graf_code ABSOLUTE $170 ;
  35.    TextPlane    : BYTE ABSOLUTE $FD52;             (* TextColor            *)
  36. (* ----------------------------------------------------------------------- *)
  37. PROCEDURE InitGrafik;                (* initialisiert und aktiviert Grafik *)
  38. BEGIN
  39.   ClrScr;
  40.   VideoIn    := toVideo;              (* ML-Routinen eintragen ,'poken'    *)
  41.   VideoOut   := fromVideo;
  42.   VideoCop   := copyVideo;
  43.   Mem[$ee29] := 01;                   (* Patch des BIOS fuer 4 Farben      *)
  44.   Mem[$ee2a] := 05;
  45.   Mem[$ee37] := 06;                   (* Modus 6, wie im Basic             *)
  46.   Mem[$e092] := $27;                  (* Ebene 2 = Farbe 7                 *)
  47.   Mem[$e093] := $3c;                  (* Ebene 3 = Farbe 12                *)
  48.   INLINE ($cd/$ee1d);                 (* zur Initialisierung notwendig     *)
  49. END;
  50. (* ----------------------------------------------------------------------- *)
  51. PROCEDURE VideoPoke (adr: INTEGER; wert: BYTE);
  52. BEGIN
  53.   INLINE ($3a/wert/$2a/adr/$cd/$130);
  54. END;                              (* LD A,(wert)  LD HL,(adr) CALL toVideo *)
  55.  
  56. FUNCTION  VideoAddr (x,y: INTEGER): INTEGER;
  57. BEGIN  VideoAddr :=  y * 80 + x SHR 3 + VideoBegin;  END;
  58. (* ----------------------------------------------------------------------- *)
  59. (*     Fuellt Farbtopf (Plane = 0,1,2 oder 3) mit gewuenschter Farbe:      *)
  60. PROCEDURE SetColor (Plane: Planes; Color: SysColors);
  61. BEGIN
  62.   Port[PALPort] := (Ord(Color)) OR ((Plane*16) AND $30);
  63. END;
  64.  
  65. PROCEDURE SetPalette (Col0, Col1, Col2, Col3: SysColors);       (* klar ?! *)
  66. BEGIN
  67.   SetColor(0,Col0);  SetColor(1,Col1);  SetColor(2,Col2);  SetColor(3,Col3);
  68. END;
  69. (* ----------------------------------------------------------------------- *)
  70. (*        waehlt Farbtopf fuer folgende Zeichen-Operationen aus:           *)
  71. PROCEDURE Color (Col: Planes);
  72. VAR temp: BYTE;
  73. BEGIN
  74.   temp := Col;                        (* Farbtopfnummer an Ebene anpassen: *)
  75.   IF temp > 1 THEN temp := temp + 2;
  76.   temp := temp AND 5;  Port[WritePort] := temp OR $C0;
  77. END;
  78.  
  79. (* setzt einen Punkt in der Farbe des mit Color() ausgewaehlten Farbtopfes *)
  80. PROCEDURE SetPixel (x,y: INTEGER);
  81. VAR adr: INTEGER;  wert: BYTE;
  82. BEGIN
  83. IF (x > -1) AND (x <= ScreenXmax) AND  (y > -1) AND (y <= ScreenYmax) THEN
  84.   BEGIN
  85.     adr := VideoAddr(x,y);  wert:= 1 SHL (x AND 7);  VideoPoke (adr,wert);
  86.   END;
  87. END;
  88.  
  89. (*   setzt einen Punkt mit der Farbe aus dem mit Col gewaehlten Farbtopf:  *)
  90. PROCEDURE Plot (x,y: INTEGER; Col: Planes);
  91. BEGIN  Color(Col);  SetPixel(x,y);  END;
  92.  
  93. PROCEDURE Draw (ax,ay,bx,by: INTEGER; Col: Planes);    (* dito, eine Linie *)
  94. VAR xdiff, ydiff, xstep, ystep, summe, merker: INTEGER;
  95. BEGIN
  96.   Color(Col);
  97.   IF (ax <> bx) OR (ay <> by) THEN BEGIN
  98.     xdiff := bx-ax;  ydiff := by-ay;  xstep := 1;  ystep := 1;
  99.     IF xdiff < 0 THEN  BEGIN  xstep := -1;  xdiff := abs(xdiff);  END;
  100.     IF ydiff < 0 THEN  BEGIN  ystep := -1;  ydiff := abs(ydiff);  END;
  101.     IF xdiff <> 0 THEN summe := 0  ELSE  summe := -1;
  102.     merker := summe;
  103.     REPEAT
  104.       IF summe < 0 THEN  BEGIN  ay := ay+ystep;  summe := summe+xdiff  END
  105.       ELSE  BEGIN  ax := ax+xstep;  summe := summe-ydiff;  END;
  106.       IF (merker < 0) OR (summe > -1) THEN SetPixel (ax,ay);
  107.       merker := summe;
  108.     UNTIL (ax = bx) AND (ay = by);
  109.   END;
  110. END;
  111. (* ----------------------------------------------------------------------- *)
  112. (*                     Pixel aus Farbtopf abfragen:                        *)
  113. FUNCTION ColSearch (adr: INTEGER; Color: Planes): BYTE;
  114. VAR help, temp: BYTE;
  115. BEGIN
  116.   temp := Color;  IF temp > 1 THEN temp := temp + 2;
  117.   INLINE ($3a/temp/$f6/$80/$d3/ReadPort/$2a/adr/$cd/$140/$32/help);
  118.   (* LD A,(temp)  OR $80  OUT($CD),A  LD  HL,(ADR) CALL fromVideo
  119.      LD (help), A                                                  *)
  120.   ColSearch := help;
  121. END;
  122.  
  123. (* pruefen, ob Punkt aus dem genannten Farbtopf gesetzt ist. Wenn ja, ist  *)
  124. (*                      GetPixel TRUE, sonst FALSE:                        *)
  125. FUNCTION GetPixel (x,y: INTEGER; Color: Planes): BOOLEAN;
  126. VAR inhalt, wert: BYTE;  adr: INTEGER;
  127. BEGIN
  128.   adr := VideoAddr(x,y);    inhalt := ColSearch(adr,Color);
  129.   wert := 1 SHL (x AND 7);  GetPixel := (inhalt AND wert) <> 0;
  130. END;
  131. (* ----------------------------------------------------------------------- *)
  132. PROCEDURE TextColor (Color: Planes);                   (* Textfarbe setzen *)
  133. VAR temp: BYTE;
  134. BEGIN
  135.   temp := Color;  IF temp > 1 THEN temp := temp + 2;  TextPlane := temp;
  136. END;
  137.  
  138. PROCEDURE BORDER (Col: SysColors);                    (* Randfarbe  setzen *)
  139. BEGIN  INLINE (1/$6cf/$3a/Col/$ed/$79);  END;
  140. (* ----------------------------------------------------------------------- *)
  141. PROCEDURE hardcopy; (* fuer den ITOH 8510 *)
  142.  CONST esc       = #27;
  143.        normal    = #27'A';                      (* normaler Zeilenabstand  *)
  144.        eng       = #27'T16';                    (* Abstand  16/144 Zoll    *)
  145.        uni       = #27#62;                      (* unidirektional          *)
  146.        bi        = #27#60;                      (* bidirektional           *)
  147.        fett      = #27'!';                      (* doppelter Anschlag      *)
  148.        unfett    = #27'"';                      (* einfacher Anschlag      *)
  149.        gstring   = #27'S0640';                (* es folgen 640 Grafikbytes *)
  150.        CR        = #13;
  151.        maxzeile  = 47;                          (* 48  Halbzeilen          *)
  152.        maxspalte = 79;                          (* 80 Bytes Breite         *)
  153.  TYPE  feld8     = ARRAY [0..7] OF BYTE;
  154.  VAR   f: TEXT;  DrZeile: 0..maxzeile;  Drspalte: 0..maxspalte;  code: feld8;
  155.        k,nochmal : BYTE;
  156.  
  157.   PROCEDURE hol8BYTE (x,y: INTEGER; VAR code: feld8; Col: Planes);
  158.   VAR adr, i: INTEGER;   inhalt, wert2: BYTE;
  159.   BEGIN
  160.     adr := y * 320 + x + VideoBegin;
  161.     FOR i := 0 TO 3 DO BEGIN
  162.       inhalt := ColSearch(adr, Col);
  163.       IF Col = 2 THEN wert2 := 0 ELSE wert2 := inhalt;
  164.       code[i*2]   := inhalt;             (* Zur vertikalen Spreizung jede  *)
  165.       code[i*2+1] := wert2;              (* Zeile in 2 Halbzeilen zerlegen *)
  166.       adr := adr+80;                       (* und halbe Zeile doppeln      *)
  167.     END;
  168.   END;
  169.  
  170.   PROCEDURE drucke (acht: feld8);
  171.   VAR  zeile, spalte: 0..7;  drBYTE: feld8;
  172.   BEGIN
  173.     INLINE ($f3/$0e/8/$21/drBYTE/$36/0/6/8/ $11/acht/$1a/$cb/$3f/
  174.             $12/$cb/$1e/$13/$10/$f7/$23/ $0d/$20/$ec/$fb);
  175.     FOR spalte := 0 TO 7 DO Write(f,Chr(drBYTE[spalte]));
  176.   END;
  177.  
  178. BEGIN (* hardcopy *)
  179.   Assign (f,'LST:');  WriteLn(f,uni,eng);
  180.   WriteLn(f,esc,'N');              (* esc 'N' ist Schnellschrift, 640 Dots *)
  181.   FOR DrZeile := 0 TO maxzeile  DO BEGIN
  182.     WriteLn(f);  k := 1;
  183.     FOR nochmal := 1 TO 3 DO BEGIN;
  184.       IF k = 3 THEN Write(f,fett) ELSE Write (f,unfett);
  185.       Write(f,gstring);
  186.       FOR Drspalte := 0 TO maxspalte DO BEGIN
  187.         hol8BYTE(Drspalte,DrZeile,code,k);  drucke(code);
  188.       END;
  189.       Write(f,CR);
  190.       IF k = 2 THEN k := 3 ELSE IF k = 1 THEN k := 2;
  191.     END;
  192.   END;
  193.   WriteLn(f,bi,normal,unfett);  WriteLn(f);
  194. END;      (* hardcopy *)
  195. (* ----------------------------------------------------------------------- *)
  196. (*              Die folgenden Routinen bitte selbst schreiben
  197. PROCEDURE moveto (x,y: INTEGER);
  198. PROCEDURE drawto (x,y: INTEGER; Col: Planes);
  199. PROCEDURE box (x1,y1,x2,y2: INTEGER; Col: Planes);
  200. PROCEDURE circle (mx,my,rd: INTEGER; elli: real; Col: Planes);
  201. PROCEDURE fill (x,y: INTEGER; Col: Planes);
  202.   siehe Serie 'Vom Punkt zur dritten Dimension' in PASCAL INTERNATIONAL    *)
  203. (* ----------------------------------------------------------------------- *)
  204. PROCEDURE PicSave (name: PicName);
  205. VAR datei: FILE;  i,ort,k,dummi: INTEGER;   records: BYTE;
  206.     Puffer: ARRAY [1..VideoSize] OF BYTE;
  207. BEGIN
  208.   records:= VideoSize DIV 128;  dummi := (VideoRAM DIV VideoSize) -1;
  209.   name := name+'.PIC'; Assign(datei,name);  ReWrite(datei);
  210.   Port[ReadPort] := 1;                (* zuerst Ebene 1 auslesen           *)
  211.   FOR k := 1 TO 2 DO BEGIN
  212.     FOR i := 0 TO dummi DO BEGIN
  213.       ort := i * VideoSize + VideoBegin;
  214.       INLINE (1/VideoSize/$2a/ort/$11/Puffer/$cd/$170);
  215.       BlockWrite(datei,Puffer,records);
  216.     END;
  217.     Port[ReadPort] := 4;              (* und dann Ebene 4                  *)
  218.  END;
  219.  Close(datei);
  220. END;
  221.  
  222. PROCEDURE PicLoad (name: PicName);
  223. VAR datei: FILE;  k,i,ort,dummi: INTEGER;  records: BYTE;
  224.     Puffer: ARRAY [1..VideoSize] OF BYTE;
  225. BEGIN
  226.   records := VideoSize DIV 128;  dummi := (VideoRAM DIV VideoSize) -1;
  227.   name := name+'.PIC';  Assign(datei,name);  ReSet(datei);
  228.   Port[WritePort] := $41;              (* Ebene 1 zur Aufnahme vorbereiten *)
  229.   FOR k := 1 TO 2 DO BEGIN             (* und auf Oderverknuepfung schalten*)
  230.     FOR i := 0 TO dummi DO BEGIN
  231.       BlockRead(datei,Puffer,records);   ort := i * VideoSize  + VideoBegin;
  232.       INLINE(1/VideoSize/$21/Puffer/$ed/$5b/ort/$cd/$170);
  233.     END;
  234.     Port[WritePort] := $44;             (* nochmal in Ebene 4 laden, ODERn *)
  235.   END;
  236.   Close(datei);
  237. END;
  238. (* ----------------------------------------------------------------------- *)
  239.