home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / dev / obero / oberon-a / source / projectoberon / display.mod < prev    next >
Encoding:
Text File  |  1995-07-02  |  13.9 KB  |  512 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: Display.mod $
  4.   Description: Clone of the Project Oberon Display module.
  5.                Interface based on module Display for Ceres Oberon System.
  6.                NW 3.3.89 / 19.1.91 / 22.11.92
  7.  
  8.    Created by: fjc (Frank Copeland)
  9.     $Revision: 1.2 $
  10.       $Author: fjc $
  11.         $Date: 1995/06/04 23:24:07 $
  12.  
  13.   Copyright © 1995, Frank Copeland.
  14.   This file is part of the Oberon-A Library.
  15.   See Oberon-A.doc for conditions of use and distribution.
  16.  
  17. *************************************************************************)
  18.  
  19. <*STANDARD-*>
  20.  
  21. MODULE Display;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM, Kernel, Errors, e := Exec, d := Dos, gfx := Graphics,
  25.   as := AmigaSupport;
  26.  
  27. CONST
  28.   black* = 0; white* = 1;
  29.   replace* = 0; paint* = 1; invert* = 2;
  30.  
  31. TYPE
  32.   Frame* = POINTER TO FrameDesc;
  33.   FrameMsg* = RECORD END;
  34.   Pattern* = LONGINT;
  35.   PatternPtr = POINTER [1] TO PatternDesc;
  36.   Font* = POINTER TO Bytes;
  37.   Cache = RECORD
  38.     dx, x, y, w, h : INTEGER;
  39.     pat : PatternPtr;
  40.   END;
  41.   Bytes* = RECORD
  42.     textFont *: gfx.TextFontPtr;
  43.     cache : ARRAY 256 OF Cache;
  44.   END;
  45.  
  46.   Handler* = PROCEDURE (f: Frame; VAR msg: FrameMsg);
  47.  
  48.   FrameDesc* = RECORD
  49.     dsc*, next*: Frame;
  50.     X*, Y*, W*, H*: INTEGER;
  51.     handle*: Handler
  52.   END;
  53.  
  54. VAR
  55.   Unit*: LONGINT; (*RasterUnit = Unit/36000 mm*)
  56.   Left*, ColLeft*, Bottom*, UBottom*, Width*, Height*: INTEGER;
  57.   arrow*, star*, hook*, cross*, downArrow*: Pattern;
  58.   grey0*, grey1*, grey2*, ticks*: Pattern;
  59.  
  60.  
  61. CONST
  62.   replaceTerm = -40H;
  63.   paintTerm   = -10H;
  64.   invertTerm  = -40H;
  65.  
  66. TYPE
  67.   PatternDesc = RECORD [1]
  68.     w, h, W : INTEGER;
  69.     raster : gfx.PLANEPTR;
  70.     next : PatternPtr;
  71.   END; (* PatternDesc *)
  72.  
  73. VAR
  74.   patterns : PatternPtr;
  75.  
  76.  
  77. PROCEDURE Round16 ( x : INTEGER ) : INTEGER;
  78. BEGIN INC (x, 15); RETURN x - (x MOD 16)
  79. END Round16;
  80.  
  81. PROCEDURE Round32 ( x : INTEGER ) : INTEGER;
  82. BEGIN INC (x, 31); RETURN x - (x MOD 32)
  83. END Round32;
  84.  
  85. PROCEDURE MapX ( x : INTEGER ) : INTEGER;
  86. BEGIN RETURN x + as.win.borderLeft
  87. END MapX;
  88.  
  89. PROCEDURE MapY ( y : INTEGER ) : INTEGER;
  90. BEGIN RETURN as.win.height - as.win.borderBottom - y - 1
  91. END MapY;
  92.  
  93.  
  94. PROCEDURE Map* ( X : INTEGER ) : LONGINT;
  95. BEGIN RETURN 0
  96. END Map;
  97.  
  98. PROCEDURE SetMode* ( X : INTEGER; s : SET );
  99. BEGIN
  100. END SetMode;
  101.  
  102. PROCEDURE SetColor* ( col, red, green, blue : INTEGER );
  103. (*col < 0: overlay color*)
  104. BEGIN
  105.   as.BeginUpdate;
  106.     gfx.SetRGB4 ( SYS.ADR (as.scr.viewPort), ABS (col),
  107.                   SHORT (red), SHORT (green), SHORT (blue));
  108.   as.EndUpdate;
  109. END SetColor;
  110.  
  111. PROCEDURE GetColor* ( col : INTEGER; VAR red, green, blue : INTEGER );
  112.   VAR color : INTEGER;
  113. BEGIN
  114.   as.BeginUpdate;
  115.     color := gfx.GetRGB4 (as.scr.viewPort.colorMap, col);
  116.     red := SYS.LSH (color, -8) MOD 16;
  117.     green := SYS.LSH (color, -4) MOD 16;
  118.     blue := color MOD 16;
  119.   as.EndUpdate;
  120. END GetColor;
  121.  
  122. PROCEDURE SetCursor* ( mode : SET );
  123. (*color cursor; 0: crosshair, 1: arrow*)
  124. BEGIN
  125. END SetCursor;
  126.  
  127. PROCEDURE DefCC* ( x, y, w, h : INTEGER );  (*crosshair window*)
  128. BEGIN
  129. END DefCC;
  130.  
  131. PROCEDURE DefCP* (VAR raster: ARRAY OF SYS.BYTE);  (*cursor pattern*)
  132. BEGIN
  133. END DefCP;
  134.  
  135. PROCEDURE DrawCX* ( x, y : INTEGER );
  136. BEGIN
  137. END DrawCX;
  138.  
  139. PROCEDURE FadeCX* ( x, y : INTEGER );
  140. BEGIN
  141. END FadeCX;
  142.  
  143. PROCEDURE GetChar* (*get raster data of character ch*)
  144.   ( f : Font; ch : CHAR;
  145.     VAR dx, x, y, w, h : INTEGER;
  146.     VAR p : LONGINT );
  147.  
  148.   TYPE
  149.     CharLoc = RECORD [1] offset, size : INTEGER END;
  150.     CharLocPtr = POINTER [1] TO ARRAY 256 OF CharLoc;
  151.     WordArray = POINTER [1] TO ARRAY 256 OF INTEGER;
  152.  
  153.   VAR
  154.     tf : gfx.TextFontPtr; charLoc : CharLocPtr;
  155.     charSpace, charKern : WordArray; charData : e.APTR;
  156.     dx0, x0, y0, w0, h0, i, W : INTEGER; pat : PatternPtr;
  157.     rp : gfx.RastPort; bm : gfx.BitMap; text : ARRAY 2 OF CHAR;
  158.  
  159. BEGIN
  160.   ASSERT (f # NIL, 97);
  161.   IF f.cache[ORD(ch)].dx # 0 THEN (* Return cached values *)
  162.     dx := f.cache[ORD(ch)].dx;
  163.     x := f.cache[ORD(ch)].x;
  164.     y := f.cache[ORD(ch)].y;
  165.     w := f.cache[ORD(ch)].w;
  166.     h := f.cache[ORD(ch)].h;
  167.     p := SYS.VAL (LONGINT, f.cache[ORD(ch)].pat)
  168.   ELSE
  169.     ASSERT (f.textFont # NIL, 97); tf := f.textFont;
  170.  
  171.     IF (ch >= tf.loChar) & (ch <= tf.hiChar) THEN
  172.       (* Calculate char metrics *)
  173.  
  174.       charLoc := tf.charLoc; i := ORD (ch) - ORD (tf.loChar);
  175.  
  176.       IF gfx.proportional IN tf.flags THEN
  177.         charSpace := tf.charSpace; charKern := tf.charKern;
  178.         dx0 := charSpace[i] + charKern[i];
  179.         w0 := charLoc[i].size + charKern[i]
  180.       ELSE
  181.         dx0 := tf.xSize; w0 := charLoc[i].size;
  182.       END;
  183.       x0 := 0; y0 := tf.baseline - tf.ySize; h0 := tf.ySize;
  184.  
  185.       IF (w0 * h0) > 0 THEN
  186.         (* Create a pattern *)
  187.  
  188.         NEW (pat); ASSERT (pat # NIL, 98);
  189.         W := Round16 (w0);
  190.         pat.raster := gfx.AllocRaster (W, h0);
  191.         ASSERT (pat.raster # NIL, 98);
  192.         pat.w := w0; pat.h := h0; pat.W := W;
  193.         pat.next := patterns; patterns := pat;
  194.  
  195.         (* Blit the glyph data from the font to the pattern *)
  196.  
  197.         gfx.InitBitMap (bm, 1, W, h0);
  198.         bm.planes[0] := pat.raster;
  199.         gfx.InitRastPort (rp);
  200.         rp.bitMap := SYS.ADR (bm);
  201.         gfx.SetAPen (SYS.ADR (rp), 1); gfx.SetBPen (SYS.ADR (rp), 0);
  202.         gfx.SetDrMd (SYS.ADR (rp), gfx.jam2); gfx.SetFont (SYS.ADR (rp), tf);
  203.  
  204.         gfx.Move (SYS.ADR (rp), 0, tf.baseline);
  205.         text[0] := ch; text[1] := 0X; gfx.Text (SYS.ADR (rp), text, 1);
  206.       ELSE
  207.         pat := NIL
  208.       END;
  209.  
  210.       (* Cache for next time *)
  211.  
  212.       f.cache [ORD(ch)].dx := dx0;
  213.       f.cache [ORD(ch)].x := x0;
  214.       f.cache [ORD(ch)].y := y0;
  215.       f.cache [ORD(ch)].w := w0;
  216.       f.cache [ORD(ch)].h := h0;
  217.       f.cache [ORD(ch)].pat := pat;
  218.     ELSE
  219.       dx0 := 0; x0 := 0; y0 := 0; w0 := 0; h0 := 0; pat := NIL
  220.     END;
  221.  
  222.     (* Return values *)
  223.  
  224.     dx := dx0; x := x0; y := y0; w := w0; h := h0;
  225.     p := SYS.VAL (LONGINT, pat)
  226.   END
  227. END GetChar;
  228.  
  229. PROCEDURE NewPattern* (VAR image : ARRAY OF SET; w, h : INTEGER): Pattern;
  230.  
  231.   VAR pat : PatternPtr; W : INTEGER;
  232.  
  233. BEGIN
  234.   W := Round32 (w);
  235.   ASSERT ((LEN(image) DIV 4) <= ((W DIV 8) * h), 97);
  236.   NEW (pat); ASSERT (pat # NIL, 98);
  237.   pat.w := w; pat.h := h; pat.W := W;
  238.   pat.raster := gfx.AllocRaster (W, h); ASSERT (pat.raster # NIL, 98);
  239.   SYS.MOVE (SYS.ADR (image), pat.raster, (W DIV 8) * h);
  240.   pat.next := patterns; patterns := pat;
  241.   RETURN SYS.VAL (Pattern, pat)
  242. END NewPattern;
  243.  
  244. (*raster operations*)
  245.  
  246. PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: INTEGER);
  247.  
  248.   VAR rp : gfx.RastPortPtr; term : e.UBYTE;
  249.  
  250. BEGIN
  251.   ASSERT (as.win # NIL, 97); ASSERT (mode IN {replace, paint, invert}, 97);
  252.  
  253.   ASSERT ((sx >= 0) & (sx < Width), 97);
  254.   ASSERT ((sy >= 0) & (sy < Height), 97);
  255.   ASSERT ((dx >= 0) & (dx < Width), 97);
  256.   ASSERT ((dy >= 0) & (dy < Height), 97);
  257.   ASSERT ((w >= 0) & ((sx + w) <= Width) & ((dx + w) <= Width), 97);
  258.   ASSERT ((h >= 0) & ((sy + h) <= Height) & ((dy + h) <= Height), 97);
  259.  
  260.   as.BeginUpdate;
  261.     IF mode = replace THEN term := replaceTerm
  262.     ELSIF mode = paint THEN term := paintTerm
  263.     ELSE term := invertTerm
  264.     END;
  265.     rp := as.win.rPort;
  266.     gfx.ClipBlit ( rp, MapX (sx), MapY (sy) - h + 1,
  267.                    rp, MapX (dx), MapY (dy) - h + 1,
  268.                    w, h, term );
  269.   as.EndUpdate;
  270. END CopyBlock;
  271.  
  272. PROCEDURE CopyPattern*(col: INTEGER; pat: Pattern; x, y, mode: INTEGER);
  273.  
  274.   VAR
  275.     rp : gfx.RastPortPtr; bm : gfx.BitMap; p : PatternPtr; term : e.UBYTE;
  276.     ignore : BOOLEAN;
  277.  
  278. BEGIN
  279.   IF pat # 0 THEN
  280.     ASSERT (as.win # NIL, 97);
  281.     ASSERT (mode IN {replace, paint, invert}, 97);
  282.  
  283.     IF (x >= 0) & (x < Width) & (y >= 0) & (y < Width) THEN
  284.       as.BeginUpdate;
  285.         rp := as.win.rPort;
  286.         gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
  287.         IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
  288.         ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
  289.         ELSE gfx.SetDrMd (rp, {gfx.complement});
  290.         END;
  291.         p := SYS.VAL (PatternPtr, pat);
  292.         gfx.BltTemplate ( p.raster, 0, (p.W + 7) DIV 8,
  293.                           rp, MapX (x), MapY (y) - p.h + 1, p.w, p.h );
  294.       as.EndUpdate;
  295.     END
  296.   END
  297. END CopyPattern;
  298.  
  299. PROCEDURE ReplPattern*
  300.   ( col : INTEGER; pat : Pattern; x, y, w, h, mode : INTEGER );
  301.  
  302.   VAR rp : gfx.RastPortPtr; p : PatternPtr; x0, y0, W : INTEGER;
  303.  
  304. BEGIN
  305.   ASSERT (as.win # NIL, 97);
  306.   ASSERT (mode IN {replace, paint, invert}, 97);
  307.   ASSERT (pat # 0);
  308.  
  309.   IF (x >= 0) & (x < Width) & (y >= 0) & (y < Width) THEN
  310.     as.BeginUpdate;
  311.       rp := as.win.rPort;
  312.       gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
  313.       IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
  314.       ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
  315.       ELSE gfx.SetDrMd (rp, {gfx.complement});
  316.       END;
  317.       p := SYS.VAL (PatternPtr, pat);
  318.       x := MapX (x); y := MapY (y) - h + 1;
  319.       y0 := y;
  320.       REPEAT
  321.         x0 := x;
  322.         REPEAT
  323.           gfx.BltTemplate ( p.raster, 0, (p.W + 7) DIV 8,
  324.                             rp, x0, y0, p.w, p.h );
  325.           INC (x0, p.w)
  326.         UNTIL x0 >= x + w;
  327.         INC (y0, p.h)
  328.       UNTIL y0 >= y + h;
  329.     as.EndUpdate;
  330.   END
  331. END ReplPattern;
  332.  
  333. PROCEDURE ReplConst*(col, x, y, w, h, mode: INTEGER);
  334.  
  335.   VAR rp : gfx.RastPortPtr;
  336.  
  337. BEGIN
  338.   ASSERT (as.win # NIL, 97);
  339.   ASSERT (mode IN {replace, paint, invert}, 97);
  340.  
  341.   IF (x >= 0) & (x < Width) & (y >= 0) & (y <= Height) & (w > 0) & (h > 0)
  342.   THEN
  343.     ASSERT (w <= (Width - x), 97);
  344.     ASSERT (h <= (Height - y), 97);
  345.  
  346.     as.BeginUpdate;
  347.       rp := as.win.rPort;
  348.       gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
  349.       IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
  350.       ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
  351.       ELSE gfx.SetDrMd (rp, {gfx.complement});
  352.       END;
  353.  
  354.       x := MapX (x); y := MapY (y) - h + 1;
  355.       IF w = 1 THEN    (* Drawing a vertical line from (x,y) to (x,y+h-1) *)
  356.         gfx.Move (rp, x, y); gfx.Draw (rp, x, y + h - 1)
  357.       ELSIF h = 1 THEN (* Drawing a horizontal line from (x,y) to (x+w-1,y) *)
  358.         gfx.Move (rp, x, y); gfx.Draw (rp, x + w - 1, y)
  359.       ELSE             (* Filling a rectangle *)
  360.         gfx.RectFill (rp, x, y, x + w - 1, y + h - 1)
  361.       END;
  362.     as.EndUpdate;
  363.   END;
  364.  
  365. END ReplConst;
  366.  
  367. PROCEDURE Dot*(col, x, y, mode: INTEGER);
  368.  
  369.   VAR rp : gfx.RastPortPtr; result : BOOLEAN;
  370.  
  371. BEGIN
  372.   ASSERT (as.win # NIL, 97);
  373.   ASSERT (mode IN {replace, paint, invert}, 97);
  374.  
  375.   as.BeginUpdate;
  376.     rp := as.win.rPort;
  377.     gfx.SetAPen (rp, SHORT (col)); gfx.SetBPen (rp, 0);
  378.     IF mode = replace THEN gfx.SetDrMd (rp, gfx.jam2);
  379.     ELSIF mode = paint THEN gfx.SetDrMd (rp, gfx.jam1);
  380.     ELSE gfx.SetDrMd (rp, {gfx.complement});
  381.     END;
  382.     result := gfx.WritePixel (rp, MapX (x), MapY (y));
  383.   as.EndUpdate;
  384. END Dot;
  385.  
  386. (*raster operations with clipping*)
  387.  
  388. PROCEDURE CopyBlockC*(F: Frame; sx, sy, w, h, dx, dy, mode: INTEGER);
  389. BEGIN
  390.   CopyBlock (sx, sy, w, h, dx, dy, mode)
  391. END CopyBlockC;
  392.  
  393. PROCEDURE CopyPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, mode: INTEGER);
  394. BEGIN
  395.   CopyPattern (col, pat, x, y, mode);
  396. END CopyPatternC;
  397.  
  398. PROCEDURE ReplPatternC*(F: Frame; col: INTEGER; pat: Pattern; x, y, w, h, xp, yp, mode: INTEGER);
  399. BEGIN
  400.   ReplPattern (col, pat, x, y, w, h, mode)
  401. END ReplPatternC;
  402.  
  403. PROCEDURE ReplConstC*(F: Frame; col, x, y, w, h, mode: INTEGER);
  404. BEGIN
  405.   ReplConst (col, x, y, w, h, mode)
  406. END ReplConstC;
  407.  
  408. PROCEDURE DotC*(F: Frame; col, x, y, mode: INTEGER);
  409. BEGIN
  410.   Dot (col, x, y, mode)
  411. END DotC;
  412.  
  413.  
  414. PROCEDURE* Cleanup ( VAR rc : LONGINT );
  415.  
  416.   VAR pat, next : PatternPtr;
  417.  
  418. BEGIN (* Cleanup *)
  419.   pat := patterns;
  420.   WHILE pat # NIL DO
  421.     next := pat.next;
  422.     gfx.FreeRaster (pat.raster, pat.W, pat.h);
  423.     pat := next
  424.   END
  425. END Cleanup;
  426.  
  427.  
  428. PROCEDURE InitPatterns;
  429.  
  430.   VAR bits : ARRAY 16 OF SET; i : INTEGER;
  431.  
  432. BEGIN (* InitPatterns *)
  433.   FOR i := 0 TO 15 DO bits [i] := {} END;
  434.   bits [0] := {20..31};        bits [1] := {22..31};
  435.   bits [2] := {24..31};        bits [3] := {24..31};
  436.   bits [4] := {22..25,28..31}; bits [5] := {20..23,30..31};
  437.   bits [6] := {18..21};        bits [7] := {16..19};
  438.   bits [8] := {14..17};        bits [9] := {14..15};
  439.   arrow := NewPattern (bits, 18, 10);
  440.  
  441.   FOR i := 0 TO 15 DO bits [i] := {} END;
  442.   bits [0] := {20,21};             bits [1] := {12,13,20,21,28,29};
  443.   bits [2] := {14,15,20,21,26,27}; bits [3] := {16,17,20,21,24,25};
  444.   bits [4] := {18..23};            bits [5] := {10..31};
  445.   bits [6] := {18..23};            bits [7] := {16,17,20,21,24,25};
  446.   bits [8] := {14,15,20,21,26,27}; bits [9] := {12,13,20,21,28,29};
  447.   bits [10] := {20,21};
  448.   star := NewPattern (bits, 22, 11);
  449.  
  450.   FOR i := 0 TO 15 DO bits [i] := {} END;
  451.   bits [0] := {30,31};  bits [1] := {28..31};
  452.   bits [2] := {26..31}; bits [3] := {24..31};
  453.   bits [4] := {22..31}; bits [5] := {20..31};
  454.   bits [6] := {18..31}; bits [7] := {16..31};
  455.   hook := NewPattern (bits, 16, 8);
  456.  
  457.   FOR i := 0 TO 15 DO bits [i] := {} END;
  458.   bits [0]  := {20,21}; bits [1] := {20,21};
  459.   bits [2]  := {20,21}; bits [3] := {20,21};
  460.   bits [4]  := {20,21}; bits [5] := {10..31};
  461.   bits [6]  := {20,21}; bits [7] := {20,21};
  462.   bits [8]  := {20,21}; bits [9] := {20,21};
  463.   bits [10] := {20,21};
  464.   cross := NewPattern (bits, 22, 11);
  465.  
  466.   FOR i := 0 TO 15 DO bits [i] := {} END;
  467.   bits [0] := {24,25};
  468.   bits [1] := {24,25};
  469.   bits [2] := {24,25};
  470.   bits [3] := {24,25};
  471.   bits [4] := {24,25};
  472.   bits [5] := {24,25};
  473.   bits [6] := {18,19,24,25,30,31};
  474.   bits [7] := {20..29};
  475.   bits [8] := {22..27};
  476.   bits [9] := {24,25};
  477.   downArrow := NewPattern (bits, 14, 10);
  478.  
  479.   FOR i := 0 TO 14 BY 2 DO
  480.     bits [i] := {0,2,4,6,8,10,12,14,16,18,20,22,24,26,28,30}
  481.   END;
  482.   FOR i := 1 TO 15 BY 2 DO
  483.     bits [i] := {1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31}
  484.   END;
  485.   grey0 := NewPattern (bits, 32, 16);
  486.  
  487.   FOR i := 0 TO 14 BY 2 DO
  488.     bits [i] := {0,4,8,12,16,20,24,28}
  489.   END;
  490.   FOR i := 1 TO 15 BY 2 DO
  491.     bits [i] := {2,6,10,14,18,22,26,30}
  492.   END;
  493.   grey1 := NewPattern (bits, 32, 16);
  494.  
  495.   FOR i := 0 TO 12 BY 4 DO
  496.     bits [i] := {0,4,8,12,16,20,24,28}
  497.   END;
  498.   FOR i := 2 TO 14 BY 4 DO
  499.     bits [i] := {2,6,10,14,18,22,26,30}
  500.   END;
  501.   grey2 := NewPattern (bits, 32, 16);
  502. END InitPatterns;
  503.  
  504.  
  505. BEGIN
  506.   Kernel.SetCleanup (Cleanup);
  507.   InitPatterns;
  508.   as.OpenDisplay;
  509.   Unit := 1; Width := as.W; Height := as.H;
  510.   Left := 0; ColLeft := 0; Bottom := 0; UBottom := 0;
  511. END Display.
  512.