Oberon/ETH Oberon/2.3.7/Trace.Display.Mod

(* ETH Oberon, Copyright 1990-2003 Computer Systems Institute, ETH Zurich, CH-8092 Zurich.
Refer to the license.txt file provided with this distribution. *)

MODULE Display;

(* Native Oberon trace display driver, pjm *)

	IMPORT Kernel, SYSTEM, Objects;
	
	CONST
		BG* = 0; FG* = 15; (*background, foreground*)
		replace* = 0; paint* = 1; invert* = 2; (*operation modes*)
		
		remove* = 0; suspend* = 1; restore* = 2; newprinter* = 3; (*ControlMsg id*)
		reduce* = 0; extend* = 1; move* = 2; (*ModifyMsg id*)
		display* = 0; state* = 1; (*ModifyMsg mode*)
		screen* = 0; printer* = 1; (* DisplayMsg device *)
		full* = 0; area* = 1; contents* = 2; (* DisplayMsg id. *)
		get* = 0; set* = 1; reset* = 2; (*SelectMsg id*)
		drop* = 0; integrate* = 1; (*ConsumeMsg id*)
		
		unknown* = 0; index8* = 8; color555* = 16; color565* = 17; color664* = 18; color888* = 24; color8888* = 32;
	
	TYPE Color* = LONGINT;
			Pattern* = LONGINT;
			PatternPtr = POINTER TO RECORD w, h, pixmap: SHORTINT END;
			List = POINTER TO ListDesc;
			ListDesc = RECORD
				next: List;
				pat: PatternPtr
			END;

			Frame* = POINTER TO FrameDesc;
			FrameDesc* = RECORD (Objects.ObjDesc)
				next*, dsc*: Frame;
				X*, Y*, W*, H*: INTEGER
			END;
  
			FrameMsg* = RECORD (Objects.ObjMsg)
				F*: Frame; (*target*)
				x*, y*, res*: INTEGER
			END;
		
			ControlMsg* = RECORD (FrameMsg)
				id*: INTEGER
			END;
		
			ModifyMsg* = RECORD (FrameMsg)
				id*, mode*: INTEGER;
				dX*, dY*, dW*, dH*: INTEGER;
				X*, Y*, W*, H*: INTEGER
			END;
		
			DisplayMsg* = RECORD (FrameMsg)
				device*: INTEGER;
				id*: INTEGER;
				u*, v*, w*, h*: INTEGER
			END;
		
			LocateMsg* = RECORD (FrameMsg)
				loc*: Frame;
				X*, Y*, u*, v*: INTEGER
			END;
		
			SelectMsg* = RECORD (FrameMsg)
				id*: INTEGER;
				time*: LONGINT;
				sel*: Frame;
				obj*: Objects.Object
			END;
		
			ConsumeMsg* = RECORD (FrameMsg)
				id*: INTEGER;
				u*, v*: INTEGER;
				obj*: Objects.Object
			END;
		
			MsgProc* = PROCEDURE (VAR M: FrameMsg);

	VAR
		Unit*: LONGINT; (* RasterUnit = Unit/36000 mm *)
		Left*, (* left margin of black-and-white maps *)
		ColLeft*, (* left margin of color maps *)
		Bottom*, (* bottom of primary map *)
		UBottom*, (* bottom of secondary map *)
		Width*, (* map width *)
		Height*: (* map hight*)
			INTEGER;
			
		arrow*, star*, cross*, downArrow*, hook*: Pattern;
		grey0*, grey1*, grey2*, ticks*, solid*: Pattern;

		Broadcast*: MsgProc;

		Pat: List;

	PROCEDURE Map*(x: LONGINT): LONGINT;
	BEGIN
		Kernel.WriteString("Map(");  Kernel.WriteInt(x, 1);  Kernel.WriteString(") ");
		RETURN 0
	END Map;
	
	PROCEDURE AdjustClip*(x, y, w, h: LONGINT);
	BEGIN
		Kernel.WriteString("AdjustClip(");  Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(y, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(w, 1);
		Kernel.WriteChar(",");  Kernel.WriteInt(h, 1);  Kernel.WriteString(") ")
	END AdjustClip;

	PROCEDURE GetDim*(pat: Pattern; VAR w, h: INTEGER);
	VAR s: SHORTINT;
	BEGIN SYSTEM.GET(pat, s); w := s; SYSTEM.GET(pat+1, s); h := s;
		Kernel.WriteString("GetDim(");  Kernel.WriteHex(pat, 8);  Kernel.WriteString(") ")
	END GetDim;

	PROCEDURE ResetClip*;
	BEGIN 
		Kernel.WriteString("ResetClip ")
	END ResetClip;
	
	PROCEDURE SetClip*(x, y, w, h: LONGINT);
	BEGIN
		Kernel.WriteString("SetClip(");  Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(y, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(w, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(h, 1);  Kernel.WriteString(") ")
	END SetClip;
	
	PROCEDURE GetClip*(VAR x, y, w, h: INTEGER);
	BEGIN
		Kernel.WriteString("GetClip ");
		x := 0;  y := 0;  w := Width;  h := Height
	END GetClip;
	
	PROCEDURE SetColor*(col: Color; red, green, blue: LONGINT);	(* 0 <= col, red, green, blue < 256 *)
	BEGIN
		Kernel.WriteString("SetColor(");  Kernel.WriteInt(col, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(red, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(green, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(blue, 1);  Kernel.WriteString(") ")
	END SetColor;

	PROCEDURE GetColor*(col: Color; VAR red, green, blue: INTEGER);
	BEGIN
		Kernel.WriteString("GetColor(");  Kernel.WriteInt(col, 1);  Kernel.WriteString(") ");
		IF col < 0 THEN
			red := SHORT(ASH(col, -16) MOD 256);
			green := SHORT(ASH(col, -8) MOD 256);
			blue := SHORT(col MOD 256)
		ELSE
			red := 0;  green := 0;  blue := 0
		END
	END GetColor;

	PROCEDURE RGB*(red, green, blue: LONGINT): Color;
	BEGIN
		Kernel.WriteString("RGB(");  Kernel.WriteInt(red, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(green, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(blue, 1);
		Kernel.WriteString(") ");
		RETURN MIN(LONGINT) + ASH(red, 16) + ASH(green, 8) + blue
	END RGB;

	PROCEDURE Dot*(col: Color; x, y, mode: LONGINT);
	BEGIN
		Kernel.WriteString("Dot(");  Kernel.WriteInt(col, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(y, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(mode, 1);  Kernel.WriteString(") ")
	END Dot;
	
	PROCEDURE CopyBlock*(sx, sy, w, h, dx, dy, mode: LONGINT);
	BEGIN 
		Kernel.WriteString("CopyBlock(");  Kernel.WriteInt(sx, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(sy, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(h, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(dx, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(dy, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  Kernel.WriteString(") ")
	END CopyBlock;
	
	PROCEDURE SetMode*(x: LONGINT; s: SET);
	BEGIN
		Kernel.WriteString("SetMode(");  Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");
		Kernel.WriteHex(SYSTEM.VAL(LONGINT, s), 8);  Kernel.WriteString(") ")
	END SetMode;
	
	PROCEDURE CopyPattern*(col: Color; pat: Pattern; x, y, mode: LONGINT);
	BEGIN
		Kernel.WriteString("CopyPattern(");  Kernel.WriteInt(col, 1);  Kernel.WriteChar(",");
		Kernel.WriteHex(pat, 8);  Kernel.WriteChar(",");  Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(y, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  Kernel.WriteString(") ")
	END CopyPattern;
	
	PROCEDURE ReplConst*(col: Color; x, y, w, h, mode: LONGINT);	(* col not used if mode is invert *)
	BEGIN
		Kernel.WriteString("ReplConst(");  Kernel.WriteInt(col, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(y, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(h, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  
		Kernel.WriteString(") ")
	END ReplConst;
	
	PROCEDURE FillPattern*(col: Color; pat: Pattern; px, py, x, y, w, h, mode: LONGINT);
	BEGIN
		Kernel.WriteString("FillPattern(");  Kernel.WriteInt(col, 1);  Kernel.WriteChar(",");
		Kernel.WriteHex(pat, 8);  Kernel.WriteChar(",");  Kernel.WriteInt(px, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(py, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(x, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(y, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(h, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  Kernel.WriteString(") ")
	END FillPattern;

	PROCEDURE ReplPattern*(col: Color; pat: Pattern; x, y, w, h, mode: LONGINT);
	BEGIN
		Kernel.WriteString("Repl/");
		FillPattern(col, pat, 0, 0, x, y, w, h, mode)
	END ReplPattern;
	
	PROCEDURE NewPattern*(w, h: LONGINT; VAR image: ARRAY OF SET): Pattern;
	VAR len, src, dest: LONGINT; i: INTEGER; p: PatternPtr; inter: SET;  pl: List;
	BEGIN
		Kernel.WriteString("NewPattern(");  Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(h, 1);  Kernel.WriteString(") ");
		len := (w+7) DIV 8;
		SYSTEM.NEW(p, 4+len*h); p.w := SHORT(SHORT(w)); p.h := SHORT(SHORT(h));
		src := SYSTEM.ADR(image); dest := SYSTEM.ADR(p.pixmap);
		i := 0;
		WHILE i < h DO SYSTEM.MOVE(src, dest, len); INC(src, 4); INC(dest, len); INC(i) END;
		NEW(pl);  pl.pat := p;  pl.next := Pat;  Pat := pl;	(* put in list to avoid GC *)
		RETURN SYSTEM.ADR(p.w)
	END NewPattern;
	
	PROCEDURE CreatePatterns;
	VAR image: ARRAY 16 OF SET;
	BEGIN
		image[0] := {13};
		image[1] := {12..14};
		image[2] := {11..13};
		image[3] := {10..12};
		image[4] := {9..11};
		image[5] := {8..10};
		image[6] := {7..9};
		image[7] := {0, 6..8};
		image[8] := {0, 1, 5..7};
		image[9] := {0..2, 4..6};
		image[10] := {0..5};
		image[11] := {0..4};
		image[12] := {0..5};
		image[13] := {0..6};
		image[14] := {0..7};
		arrow := NewPattern(15, 15, image);
		
		image[0] := {0, 10};
		image[1] := {1, 9};
		image[2] := {2, 8};
		image[3] := {3, 7};
		image[4] := {4, 6};
		image[5] := {};
		image[6] := {4, 6};
		image[7] := {3, 7};
		image[8] := {2, 8};
		image[9] := {1, 9};
		image[10] := {0, 10};
		cross := NewPattern(11, 11, image); 
		
		image[0] := {6};
		image[1] := {5..7};
		image[2] := {4..8};
		image[3] := {3..9};
		image[4] := {2..10};
		image[5] := {5..7};
		image[6] := {5..7};
		image[7] := {5..7};
		image[8] := {5..7};
		image[9] := {5..7};
		image[10] := {5..7};
		image[11] := {5..7};
		image[12] := {5..7};
		image[13] := {5..7};
		image[14] := {};
		downArrow := NewPattern(15, 15, image);
		
		image[0] := {0, 4, 8, 12};
		image[1] := {};
		image[2] := {2, 6, 10, 14};
		image[3] := {};
		image[4] := {0, 4, 8, 12};
		image[5] := {};
		image[6] := {2, 6, 10, 14};
		image[7] := {};
		image[8] := {0, 4, 8, 12};
		image[9] := {};
		image[10] := {2, 6, 10, 14};
		image[11] := {};
		image[12] := {0, 4, 8, 12};
		image[13] := {};
		image[14] := {2, 6, 10, 14};
		image[15] := {};
		grey0 := NewPattern(16, 16, image);
		
		image[0] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[1] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[2] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[3] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[4] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[5] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[6] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[7] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[8] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[9] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[10] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[11] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[12] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[13] := {1, 3, 5, 7, 9, 11, 13, 15};
		image[14] := {0, 2, 4, 6, 8, 10, 12, 14};
		image[15] := {1, 3, 5, 7, 9, 11, 13, 15};
		grey1 := NewPattern(16, 16, image);
		
		image[0] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[1] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[2] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[3] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[4] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[5] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[6] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[7] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[8] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[9] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[10] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[11] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[12] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[13] := {0, 1, 4, 5, 8, 9, 12, 13};
		image[14] := {2, 3, 6, 7, 10, 11, 14, 15};
		image[15] := {2, 3, 6, 7, 10, 11, 14, 15};
		grey2 := NewPattern(16, 16, image);
		
		image[0] := {0..2, 8..11};
		image[1] := {0..2, 7..10};
		image[2] := {0..2, 6..9};
		image[3] := {0..2, 5..8};
		image[4] := {0..2, 4..7};
		image[5] := {0..6};
		image[6] := {0..5};
		image[7] := {0..4};
		image[8] := {0..3};
		image[9] := {0..2};
		image[10] := {0, 1};
		image[11] := {0};
		hook := NewPattern(12, 12, image);
		
		image[0] := {7};
		image[1] := {7};
		image[2] := {2, 7, 12};
		image[3] := {3, 7, 11};
		image[4] := {4, 7, 10};
		image[5] := {5, 7, 9};
		image[6] := {6..8};
		image[7] := {0..6, 8..14};
		image[8] := {6..8};
		image[9] := {5, 7, 9};
		image[10] := {4, 7, 10};
		image[11] := {3, 7, 11};
		image[12] := {2, 7, 12};
		image[13] := {7};
		image[14] := {7};
		star := NewPattern(15, 15, image);
		
		image[0] := {};
		image[1] := {};
		image[2] := {0};
		image[3] := {};
		image[4] := {};
		image[5] := {};
		image[6] := {};
		image[7] := {};
		image[8] := {};
		image[9] := {};
		image[10] := {};
		image[11] := {};
		image[12] := {};
		image[13] := {};
		image[14] := {};
		image[15] := {};
		ticks := NewPattern(16, 16, image);
		
		image[0] := -{};
		image[1] := -{};
		solid := NewPattern(16, 2, image);
		
	END CreatePatterns;
	
	PROCEDURE Depth*(x: LONGINT): INTEGER;
	BEGIN
		Kernel.WriteString("Depth(");  Kernel.WriteInt(x, 1);  Kernel.WriteString(") ");
		RETURN 8
	END Depth; 
	
	PROCEDURE TrueColor*(x: LONGINT): BOOLEAN;
	BEGIN
		RETURN FALSE
	END TrueColor;

	PROCEDURE DisplayBlock*(adr, dx, dy, w, h, sx, sy, mode: LONGINT);
	BEGIN
		Kernel.WriteString("DisplayBlock(");  Kernel.WriteHex(adr, 8);  Kernel.WriteChar(",");
		Kernel.WriteInt(dx, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(dy, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(h, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(sx, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(sy, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  
		Kernel.WriteString(") ")
	END DisplayBlock;

	PROCEDURE TransferFormat*(x: LONGINT): LONGINT;
	BEGIN
		Kernel.WriteString("TransferFormat(");  Kernel.WriteInt(x, 1);  Kernel.WriteString(") ");
		RETURN unknown
	END TransferFormat;

	PROCEDURE TransferBlock*(VAR buf: ARRAY OF CHAR;  ofs, stride, x, y, w, h, mode: LONGINT);
	BEGIN
		Kernel.WriteString("TransferBlock(");  Kernel.WriteHex(SYSTEM.ADR(buf[0]), 8);  Kernel.WriteChar(",");
		Kernel.WriteInt(ofs, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(stride, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(x, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(y, 1);  
		Kernel.WriteChar(",");  Kernel.WriteInt(w, 1);  Kernel.WriteChar(",");
		Kernel.WriteInt(h, 1);  Kernel.WriteChar(",");  Kernel.WriteInt(mode, 1);  
		Kernel.WriteString(") ")
	END TransferBlock;
	
BEGIN
	Width := 640;
	Height := 480;
	Left:= 0;
	ColLeft:= 0;
	Bottom:= 0;
	UBottom:= -330; 
	CreatePatterns;
	Unit := 10000
END Display.