i21edu/Mod/TPGraphics.odc

MODULE  i21eduTPGraphics;
(* 
2014-02-06 ФВТ оптимизация отрисовки по требованию педагогических тружеников.
2003 ФВТ для проекта Информатика-21; предложение Л.Г.Куркиной и А.И.Попкова 
*)

	IMPORT  Log := StdLog,  Views,  Properties,  Ports,  StdCmds,  Math,  Fonts, 
		Controllers,  HostPorts,  HostMenus,
		Cyr := i21sysCyrillic,  W := i21sysWindows,  Windows;
	
	TYPE
		View* = POINTER TO RECORD ( Views.View ) END;

		Element = POINTER TO ABSTRACT RECORD
			color: Ports.Color;
			next: Element
		END;
		
		ElLine = POINTER TO RECORD ( Element )
			x0, y0, x1, y1: INTEGER
		END;
		
		ElRectangle = POINTER TO RECORD ( Element )
			x0, y0, x1, y1: INTEGER
		END;
		
		ElBar = POINTER TO RECORD ( Element )
			x0, y0, x1, y1: INTEGER
		END;
		
		ElCircle = POINTER TO RECORD ( Element )
			x0, y0, x1, y1: INTEGER
		END; 
		
		ElPixel = POINTER TO RECORD ( Element )
			x, y: INTEGER
		END; 
		
		ElFillEllipse = POINTER TO RECORD ( Element )
			x0, y0, x1, y1: INTEGER;
			fillColor: Ports.Color
		END; 
		
		ElArc = POINTER TO RECORD ( Element )
			x, y, rad, stAngle, endAngle: INTEGER
		END; 
		
		ElEllipse = POINTER TO RECORD ( Element )
			x, y, xrad, yrad, stAngle, endAngle: INTEGER
		END; 
		
		ElString = POINTER TO RECORD ( Element )
			x, y: INTEGER;
			s: POINTER TO ARRAY OF CHAR;
			f: Fonts.Font
		END; 
		
	VAR
		screen: View;
		
		color*,  bkColor*,  fillColor*: Ports.Color;
		font: Fonts.Font;
		first, last: Element;
		xcur, ycur: INTEGER;
		pi180: REAL;

	(* dark colors -- background *)
		black-,  blue-,  green-,  cyan-,  red-,  magenta-,  brown-,  lightGray-,
	(* light colors -- foreground *)
		darkGray-,  lightBlue-,  lightGreen-,  lightCyan-,  lightRed-,  lightMagenta-,  yellow-,
		white-: Ports.Color;
	
	
	PROCEDURE SetColors;
	BEGIN
	(* dark colors -- background *)
		black := Ports.black;
		red := Ports.RGBColor( 230, 0, 0 );
		green := Ports.RGBColor( 0, 128, 0 );
		blue := Ports.RGBColor( 0, 0, 128 );
		cyan := Ports.RGBColor( 0, 128, 128 );
		magenta := Ports.RGBColor( 128, 0, 128 );
		brown := Ports.RGBColor( 128, 0, 0 );
		lightGray := Ports.grey25;

	(* light colors -- foreground *)
		darkGray := Ports.grey50;
		lightRed := Ports.RGBColor( 255, 100, 100 );
		lightGreen := Ports.RGBColor( 0, 255, 0 );
		lightBlue := Ports.RGBColor( 0, 0, 255 );
		lightCyan := Ports.RGBColor( 0, 255, 255 );
		lightMagenta := Ports.RGBColor( 255, 0, 255 );
		yellow := Ports.red + Ports.green;
		white := Ports.white;
	END SetColors;
	
	PROCEDURE Color ( c: INTEGER ): Ports.Color;
		VAR  res: Ports.Color;
	BEGIN
		CASE  c  OF
		(* dark colors -- background *)
		|0:  res := black
		|1:  res := blue
		|2:  res := green 
		|3:  res := cyan
		|4:  res := red
		|5:  res := magenta
		|6:  res := brown
		|7:  res := lightGray

		(* light colors -- foreground *)
		|8:  res := darkGray
		|9:  res := lightBlue
		|10:  res := lightGreen
		|11:  res := lightCyan
		|12:  res := lightRed
		|13:  res := lightMagenta
		|14:  res := yellow
		|15:  res := white
		END;
		RETURN  res
	END Color;
	
(*    (Color   ; .  1) *)
	PROCEDURE SetColor* ( c: INTEGER );
	BEGIN
		ASSERT( ( c >= 0 ) & ( c <= 15 ), 20 );
		color := Color( c )
	END SetColor;
	
(*    (Color   ; .  1) *)
	PROCEDURE SetBkColor* ( c: INTEGER );
	BEGIN
		ASSERT( ( c >= 0 ) & ( c <= 15 ), 20 );
		bkColor := Color( c );
		IF screen = NIL THEN  NEW( screen ) END;
		Views.Update( screen, Views.keepFrames )
	END SetBkColor;
	
(*       (Pattern   , . 2; Color  -  , .  1). *)
	PROCEDURE SetFillColor* ( c: INTEGER );
	BEGIN
		ASSERT( ( c >= 0 ) & ( c <= 15 ), 20 );
		fillColor := Color( c );
	END SetFillColor;
	

	PROCEDURE SetFont* ( название: ARRAY OF CHAR;  размер: INTEGER;  жирный, курсив: BOOLEAN );
		VAR  typeface: Fonts.Typeface;  style: SET;  size, weight: INTEGER;  f: Fonts.Font;
	BEGIN
		ASSERT( название # '', 20);
		typeface := название$;
		IF  курсив  THEN
			style := {Fonts.italic}
		ELSE
			style := {}
		END;
		IF  жирный  THEN
			weight := Fonts.bold
		ELSE
			weight := Fonts.normal
		END;
		ASSERT( размер > 0, 21 );
		size := размер * Fonts.point;
		f := Fonts.dir.This( typeface,  size,  style,  weight );
		IF  f # NIL  THEN
			font := f
		END
	END SetFont;
	

	PROCEDURE PixelSize ( f: Ports.Frame ): INTEGER;
		VAR  res: INTEGER;
	BEGIN
		res := MAX( f.unit, 9525 ); (* на экране в пикселях, при печати в неких условных единицах, чтобы не было слишком мелко *)
		RETURN  res
	END PixelSize;
	
	PROCEDURE ( el: Element ) Draw ( f: Ports.Frame ), NEW, ABSTRACT;
	
	PROCEDURE ( el: ElLine ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawLine( px * el.x0, px * el.y0, px * el.x1, px * el.y1, 0, el.color )
	END Draw;
	
	PROCEDURE ( el: ElRectangle ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawRect( px * el.x0, px * el.y0, px * el.x1, px * el.y1, 0, el.color )
	END Draw;
	
	PROCEDURE ( el: ElBar ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawRect( px * el.x0, px * el.y0, px * el.x1, px * el.y1, -1, el.color )
	END Draw;
	
	PROCEDURE ( el: ElCircle ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawOval( px * el.x0, px * el.y0, px * el.x1, px * el.y1, 0, el.color )
	END Draw;
	
	PROCEDURE ( el: ElPixel ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawRect( px * el.x, px * el.y, px * ( el.x + 1 ), px * ( el.y + 1 ), -1, el.color )
	END Draw;
	
	PROCEDURE ( el: ElFillEllipse ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawOval( px * el.x0, px * el.y0, px * el.x1, px * el.y1, -1, el.fillColor )
	END Draw;
	
	PROCEDURE ( el: ElArc ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;  x0, y0, x1, y1, phi0, phi1: INTEGER;
			
		PROCEDURE Convert ( a: REAL;  OUT x1, y1: INTEGER );
		BEGIN
			x1 := SHORT( ENTIER( ( el.x + el.rad * Math.Cos( a ) ) ) * px );
			y1 := SHORT( ENTIER( ( el.y - el.rad * Math.Sin( a ) ) ) * px );
		END Convert;
		
	BEGIN
		px := PixelSize( f );
		phi0 := el.stAngle;
		Convert( phi0 * pi180, x0, y0 );
		phi1 := phi0 + 1;
		WHILE  phi1 < el.endAngle  DO
			Convert( phi1 * pi180, x1, y1 );
			f.DrawLine( x0, y0, x1, y1, 0, el.color );
			x0 := x1;  y0 := y1;  phi0 := phi1;
			phi1 := phi0 + 1
		END;
		phi1 := el.endAngle;
		Convert( phi1 * pi180, x1, y1 );
		f.DrawLine( x0, y0, x1, y1, 0, el.color )
	END Draw;
	
	PROCEDURE ( el: ElEllipse ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;  x0, y0, x1, y1, phi0, phi1: INTEGER;
			
		PROCEDURE Convert ( a: REAL;  OUT x1, y1: INTEGER );
			VAR  c, s, r: REAL;
		BEGIN
			c := Math.Cos( a ) / el.xrad;
			s := Math.Sin( a ) / el.yrad;
			r := Math.Sqrt( 1 / ( c * c + s * s ) );
			x1 := SHORT( ENTIER( el.x + r * Math.Cos( a ) ) * px );
			y1 := SHORT( ENTIER( el.y - r * Math.Sin( a ) ) * px );
		END Convert;
		
	BEGIN
		px := PixelSize( f );
		phi0 := el.stAngle;
		Convert( phi0 * pi180, x0, y0 );
		phi1 := phi0 + 1;
		WHILE  phi1 < el.endAngle  DO
			Convert( phi1 * pi180, x1, y1 );
			f.DrawLine( x0, y0, x1, y1, 0, el.color );
			x0 := x1;  y0 := y1;  phi0 := phi1;
			phi1 := phi0 + 1
		END;
		phi1 := el.endAngle;
		Convert( phi1 * pi180, x1, y1 );
		f.DrawLine( x0, y0, x1, y1, 0, el.color )
	END Draw;
	
	PROCEDURE ( el: ElString ) Draw ( f: Ports.Frame );
		VAR  px: INTEGER;
	BEGIN
		px := PixelSize( f );
		f.DrawString( el.x * px, el.y * px, el.color, el.s, el.f )
	END Draw;
	

	PROCEDURE ( v: View ) Restore* ( f: Views.Frame;  l, t, r, b: INTEGER );
		VAR  el: Element;
	BEGIN
		IF screen # v THEN  screen := v  END;
		f.DrawRect( 0, 0, 1000*Ports.mm, 1000*Ports.mm, -1, bkColor );
		el := first;
		WHILE  el # NIL  DO
			el.Draw( f );
			el := el.next
		END;
	END Restore;
	
	PROCEDURE ( v: View ) HandlePropMsg- ( VAR p: Properties.Message );
	BEGIN
		WITH  p: Properties.ResizePref  DO
			p.horFitToWin := TRUE;
			p.verFitToWin := TRUE
		ELSE
		END;
	END HandlePropMsg;

	PROCEDURE^ Clear*;
	
	PROCEDURE ( рис: View ) HandleCtrlMsg* ( f: Views.Frame;  VAR msg: Views.CtrlMessage;  
																							VAR focus: Views.View );
		VAR  type: ARRAY 1000 OF CHAR;  пиксель: INTEGER;
	BEGIN
		WITH  msg: Controllers.TrackMsg  DO
			IF  Controllers.doubleClick IN msg.modifiers  THEN 
				Clear;
				screen := рис;
			ELSIF  HostPorts.right IN msg.modifiers  THEN
				HostMenus.PopupMenu
			END
		|  msg: Controllers.PollOpsMsg  DO  (* Services.GetTypeName( рис, msg.type ); *)
			msg.type := "i21eduTPGraphics.View";
		ELSE
		END;
	END HandleCtrlMsg;
	
	PROCEDURE Include ( el: Element );
	BEGIN
		ASSERT( el.next = NIL, 20 );
		IF  first = NIL  THEN
			first := el
		ELSE
			last.next := el
		END;
		last := el;
		IF screen = NIL THEN  NEW( screen ) END;
		Views.Update( screen, Views.keepFrames );
	END Include;
	
(*       (x0, y0)   (x1, y1) ,   SetColor (  ) *)
	PROCEDURE Line* ( x0, y0, x1, y1: INTEGER );
		VAR  l: ElLine;
	BEGIN
		NEW( l );
		l.color := color;
		l.x0 := x0;  l.y0 := y0;
		l.x1 := x1;  l.y1 := y1;
		Include( l );
	END Line;
	
	PROCEDURE^ MoveTo* ( x, y: INTEGER );

(*          (X, Y) ,   SetColor *)
	PROCEDURE LineTo* ( x, y: INTEGER );
		VAR  l: ElLine;
	BEGIN
		NEW( l );
		l.color := color;
		l.x0 := xcur;  l.y0 := ycur;
		l.x1 := x;  l.y1 := y;
		Include( l );
		MoveTo( x, y );
	END LineTo;
	
(*       (X, Y)    *)
	PROCEDURE MoveTo* ( x, y: INTEGER );
	BEGIN
		xcur := x;  ycur := y;
	END MoveTo;
	
(*    ,   SetColor; (x0, y0)   (x1, y1)     *)
	PROCEDURE Rectangle* ( x0, y0, x1, y1: INTEGER );
		VAR  l: ElRectangle;
	BEGIN
		NEW( l );
		l.color := color;
		l.x0 := x0;  l.y0 := y0;
		l.x1 := x1;  l.y1 := y1;
		Include( l );
	END Rectangle;
	
(*   ;     SetFillStyle; (x0, y0)   (x1, y1)    ) *)
	PROCEDURE Bar* ( x0, y0, x1, y1: INTEGER );
		VAR  l: ElBar;
	BEGIN
		NEW( l );
		l.color := color;
		l.x0 := x0;  l.y0 := y0;
		l.x1 := x1;  l.y1 := y1;
		Include( l );
	END Bar;
	
(*  , ,   SetColor; x, y   , radius  . *)
	PROCEDURE Circle* ( x, y, radius: INTEGER );
		VAR  l: ElCircle;
	BEGIN
		ASSERT( radius > 0, 20 );
		NEW( l );
		l.color := color;
		l.x0 := x - radius;  l.y0 := y - radius;
		l.x1 := x + radius;  l.y1 := y + radius;
		Include( l );
	END Circle;
	
(*     (X, Y) ,   SetColor. *)
	PROCEDURE PutPixel* ( x, y: INTEGER );
		VAR  l: ElPixel;
	BEGIN
		NEW( l );
		l.color := color;
		l.x := x;  l.y := y;
		Include( l );
	END PutPixel;
	
(*   ;     SetFillStyle. 
x, y   , xRadius, yRadius   эллипса. *)
	PROCEDURE FillEllipse* ( x, y, xradius, yradius: INTEGER );
		VAR  l: ElFillEllipse;
	BEGIN
		NEW( l );
		l.color := color;
		l.fillColor := fillColor;
		l.x0 := x - xradius;  l.y0 := y - yradius;
		l.x1 := x + xradius;  l.y1 := y + yradius;
		Include( l );
	END FillEllipse;
	
(*   , ,   SetColor; x, y   , radius  , stAngle, endAngle      ,    x   . *)
	PROCEDURE Arc* ( x, y, stAngle, endAngle, radius: INTEGER );
		VAR  l: ElArc;
	BEGIN
		NEW( l );
		l.color := color;
		l.x := x;  l.y := y;
		ASSERT( ( stAngle >= - 360 ) & ( stAngle <= + 360 ), 20 );
		l.stAngle := stAngle;
		ASSERT( ( endAngle >= - 360 ) & ( endAngle <= + 360 ), 21 );
		ASSERT( stAngle < endAngle, 22 );
		l.endAngle := endAngle;
		ASSERT( radius > 0, 23 );
		l.rad := radius;
		Include( l );
	END Arc;
	
(*   , ,   SetColor; x, y   , xRadius, yRadius  , stAngle, endAngle      ,    x   . *)
	PROCEDURE Ellipse* ( x, y, stAngle, endAngle, xradius, yradius: INTEGER );
		VAR  l: ElEllipse;
	BEGIN
		NEW( l );
		l.color := color;
		l.x := x;  l.y := y;
		ASSERT( ( stAngle >= - 360 ) & ( stAngle <= + 360 ), 20 );
		l.stAngle := stAngle;
		ASSERT( ( endAngle >= - 360 ) & ( endAngle <= + 360 ), 21 );
		ASSERT( stAngle < endAngle, 22 );
		l.endAngle := endAngle;
		ASSERT( xradius > 0, 23 );
		l.xrad := xradius;
		ASSERT( yradius > 0, 24 );
		l.yrad := yradius;
		Include( l );
	END Ellipse;
	
	PROCEDURE String* ( x, y: INTEGER;  s: ARRAY OF CHAR );
		VAR  l: ElString;
	BEGIN
		NEW( l );
		l.color := color;
		l.x := x;  l.y := y;
		l.f := font;
		NEW( l.s, LEN( s$ ) + 1 );
		Cyr.ToUnicode( s, l.s );
		Include( l );
	END String;
	
	PROCEDURE Init;
	BEGIN
		first := NIL;  last := NIL;  
		pi180 := Math.Pi() / 180;
		SetColors;  color := white;  bkColor := black;  fillColor := blue;
		font := Fonts.dir.Default();
		xcur := 0;  ycur := 0;
	END Init;
	
	PROCEDURE Open*;
		VAR  w: Windows.Window;
	BEGIN
		IF screen = NIL THEN  NEW( screen )  END;
		
		w := Windows.dir.First();
		WHILE ( w # NIL ) & ~( w.doc.ThisView() = screen ) DO
			w := Windows.dir.Next( w );
		END;
		IF  w # NIL  THEN
			Windows.dir.Select( w, ~Windows.lazy );
		ELSE
			Views.OpenAux( screen, 'картинки в стиле ТП' );
			Views.Update( screen, Views.keepFrames );
			W.AlignTopRight
		END;
	END Open;
	
	PROCEDURE Clear*;
	BEGIN  Init;  Views.Update( screen, Views.keepFrames )
	END Clear;

	PROCEDURE Close;
		VAR  w: Windows.Window;
	BEGIN
		w := Windows.dir.First();
		WHILE ( w # NIL ) & ~( w.doc.ThisView() = screen ) DO
			w := Windows.dir.Next( w );
		END;
		IF  w # NIL  THEN
			Windows.dir.Select( w, ~Windows.lazy );
			Windows.dir.Close( w );
		END;
	END Close;
	
BEGIN
	Init
CLOSE
	Close
END  i21eduTPGraphics.

i21eduTPGraphics.Open
i21примTPGraphics.Do
i21eduTPGraphics.Clear


DevDebug.UnloadThis i21примTPGraphics  i21eduTPGraphics
DevCompiler.CompileThis i21примTPGraphics  i21eduTPGraphics



 1 
 Dark Colors:
 (Foreground &Background)
 Black     0
 Blue      1
 Green     2
 Cyan      3
 Red       4
 Magenta   5
 Brown     6
 LightGray 7

 Light Colors:
 (Foreground)
 DarkGray      8
 LightBlue     9
 LightGreen   10
 LightCyan    11
 LightRed     12
 LightMagenta 13
 Yellow       14
 White        15

For flashing (blinking) text foreground, Blink = 128.
 2 
Use these constants as fill patterns for SetFillStyle.

  Constant       		Value 		Meaning :
  EmptyFill         	 0  		Uses background color
  SolidFill          	 1  		Uses draw color
  LineFill          	 2  		--- fill
  LtSlashFill        	 3 		 /// fill
  SlashFill          	 4  		/// thick fill
  BkSlashFill        	 5  		\\\ thick fill
  LtBkSlashFill      	 6  		\\\ fill
  HatchFill         	 7  		Light hatch fill
  XHatchFill       	 8  		Heavy cross hatch
  InterleaveFill   	 9  		Interleaving line
  WideDotFill     	10  		Widely spaced dot
  CloseDotFill      	11  		Closely spaced dot
  UserFill          	12  		User-defined fill