Паскаль / do4 / msqp1 / Setup&Utilites / SAMPLES / TURTLE

{ ============================= TURTLE ================================

  This unit contains procedures and functions that implement turtle
  graphics. Turtle graphics is a model for specifying relative movements
  of an imaginary pointer whose direction, color, visibility, and other
  attributes are given default values using turtle functions. To use the
  turtle module, specify Turtle in the USES section of your program.

  The following routines are public :

	InitTurtle      - Initiate turtle graphics
	Home            - Reset turtle defaults
	PenDown         - Set pen visibility
	PenState        - Get pen visibility
	FillState       - Get fill state
	FillOn          - Set fill state
	PenColor        - Set pen color index
	GetPenColor     - Get pen color index
	BorderColor     - Set border color index
	GetBorderColor  - Get border color index
	Turn            - Set direction relative to current
	TurnTo          - Set absolute direction
	GetTurn         - Get current turn angle
	Move            - Move in current direction
	MoveTo          - Move to absolute location
	Poly            - Draw a polygon
	Circle          - Draw a circle with center at current location
	Ellipse         - Draw an ellipse with center at current location
	Rectangle       - Draw a rectangle with center at current location
	ImageSize       - Get size of rectangle with top-left origin
	GetImage        - Get rectangular image with top-left origin
	PutImage        - Put rectangular image with top-left origin
	Paint           - Fill from the current location to border
	NextColorIndex  - Rotate to next color index
	NextColorValue  - Rotate to next color value
	OnScreen        - Report whether current location is on screen
	SetTWindow      - Set turtle window (viewport)
	GetTWindow      - Get turtle window (viewport)
	TUnit           - Get current turtle unit
	TCurX           - Get current x coordinate
	TCurY           - Get current y coordinate
	TurtleStat      - Get return status of turtle routine
}

UNIT turtle;

{ ===========================================================}
							INTERFACE
{ ===========================================================}

USES
	MSGraph;

TYPE
	degree = -360..360;
	twindow = RECORD
		Left, Right, Top, Bottom : Integer;
		END;

CONST
	{ Constants }
	circumference     = 360;
	halfcircumference = 180;
	maxitem = 20;
	default = -1;
	limited = 0;

	{ Screen Aspect - Adjust for your screen }
	TRatioYX : Real = 1.39;

VAR
	{ Global variables }
	tmaxx, tmaxy : Double;
	tcolorindexes : Integer;
	tcolorvalues  : Integer;

	{ ===================== Public Routines ====================== }

	PROCEDURE Move( dxy : Double );
	PROCEDURE moveto( x, y : Double );
	PROCEDURE turnto( cur_angle : degree );
	PROCEDURE turn( cur_angle : degree );
	PROCEDURE poly( n_sides : Integer; side_len : Double );
	FUNCTION  getturn : degree;

	PROCEDURE pendown( pen_on  : Boolean );
	PROCEDURE fillon( fill_on : Boolean );
	FUNCTION  penstate  : Boolean;
	FUNCTION  fillstate : Boolean;

	FUNCTION  initturtle : Boolean;
	PROCEDURE home;

	PROCEDURE bordercolor( border : Integer );
	FUNCTION  getbordercolor : Integer;
	PROCEDURE pencolor( cur_index : Integer );
	FUNCTION  getpencolor : Integer;

	FUNCTION  nextcolorindex( cur_index : Integer ) : Integer;
	PROCEDURE nextcolorvalue( action : Integer );

	PROCEDURE circle( r : Double );
	PROCEDURE ellipse( w, h : Double );
	PROCEDURE rectangle( w, h : Double );

	FUNCTION  imagesize( w, h : Double ) : LongInt;
	PROCEDURE getimage( w, h : Double; VAR buf );
	PROCEDURE putimage( VAR buf; Act : Integer );
	PROCEDURE paint;

	FUNCTION  onscreen( xcur, xMax, ycur, yMax : Double ) : Boolean;

	PROCEDURE settwindow( Left, Top, Right, Bottom : Integer );
	PROCEDURE gettwindow( VAR Left, Top, Right, Bottom : Integer );

	FUNCTION  tunit : Double;
	FUNCTION  tcurx : Double;
	FUNCTION  tcury : Double;

	FUNCTION  turtlestat : Boolean;

{ ===========================================================}
						 IMPLEMENTATION
{ ===========================================================}

{ Record for configuration and other data - hidden from user }
TYPE
	turtlerec = RECORD
		stat            : Boolean;
		pen_on          : Boolean;
		fill_on         : Integer;
		yunit           : Double;
		xcur, ycur      : Double;
		cur_index       : Integer;
		border_col      : Integer;
		cur_angle       : degree;
		palette_on      : Boolean;
		x_left, x_right : Integer;
		y_top, y_bottom : Integer
		END;

VAR
	long_colors : ARRAY[0..255] OF LongInt;
	vc : _VideoConfig;
	tc : turtlerec;


{ ======================== RGB ==============================
  Creates a composite red-green-blue color value from three
  byte values.
}
FUNCTION rgb( r, g, b : Word ) : LongInt;
BEGIN
	rgb := LongInt( LongInt( LongInt( b SHL 8 ) OR g ) SHL 8 ) OR r;
END; { rgb }

{ ======================== TurtleStat ============================
  Returns the completion status of various turtle routines.
}
FUNCTION turtlestat : Boolean;
BEGIN
	turtlestat := tc.stat;
END;  { turtlestat }

{ ======================== OnScreen ==============================
  Checks that a specified point is on the screen.
}
FUNCTION onscreen( xcur, xMax, ycur, yMax : Double ) : Boolean;
BEGIN
	IF  ((tc.xcur < -tmaxx) OR (tc.xcur > tmaxx)) OR
		((tc.ycur < -tmaxy) OR (tc.ycur > tmaxy)) THEN
		onscreen := False
	ELSE
		onscreen := True;
END; { onscreen }

{ ============================ initturtle ====================================
  Initializes all turtle defaults. This function should be called at
  least once (after _SetVideoMode and _GetVideoConfig) and additionally
  after any change to a new graphics mode.

  Params: vc - videoconfig record

  Return: True or False

  Uses:   tc record variable, long_colors array
}
FUNCTION initturtle : Boolean;
CONST
	Mode : Integer = -1;    { Impossible value }

VAR
	i, incr : Integer;
	r, g, b  : Word;

BEGIN
	_GetVideoConfig( vc  );

	{ Terminate if not graphics mode. }
	IF (vc.NumXPixels = 0) THEN
		BEGIN
		initturtle := False;
		Exit;
		END
	ELSE
		initturtle := True;

	{ If mode has changed, set window coordinates. }
	IF (Mode <> vc.Mode) THEN
		BEGIN
		Mode := vc.Mode;
		tc.x_left := 0;
		tc.y_top := 0;
		tc.x_right := vc.NumXPixels - 1;
		tc.y_bottom := vc.NumYPixels - 1;
		END;

	{ Set palette flag. }
	CASE vc.Adapter OF
		_MDPA,
		_CGA,
		_OCGA,
		_HGC :
			tc.palette_on := False;
		ELSE
			tc.palette_on := True
	END; { CASE }

	CASE vc.Mode OF
		_HResBW,
		_HercMono,
		_EResNoColor,
		_OResColor,
		_VRes2Color :
			BEGIN
			tcolorvalues := 0;
			tcolorindexes := 2;
			home;
			Exit;
			END;
									{ Active bits in this order:          }
		_MRes256Color :
			BEGIN                   { ???????? ??bbbbbb ??gggggg ??rrrrrr }
			incr := 12;
			tcolorvalues := 125;
			tcolorindexes := 125;
			END;

		_EResColor :
			IF (vc.Memory = 64) THEN
				BEGIN               { ???????? ??Bb???? ??Gg???? ??Rr???? }
				incr := 32;
				tcolorvalues := 16;
				tcolorindexes := 4;
				END
			ELSE
				BEGIN               { ???????? ??bb???? ??gg???? ??rr???? }
				incr := 16;
				tcolorvalues := 64;
				tcolorindexes := 16;
				END;

		_VRes16Color:
			BEGIN                   { ???????? ??bb???? ??gg???? ??rr???? }
			incr := 16;
			tcolorvalues := 64;
			tcolorindexes := 16;
			END;

		_MRes4Color,
		_MResNoColor:
			BEGIN                   { ???????? ??Bb???? ??Gg???? ??Rr???? }
			incr := 32;
			tcolorvalues := 16;
			tcolorindexes := 4;
			END;

		_MRes16Color,
		_HRes16Color :
			BEGIN                     { ???????? ??????Bb ??????Gg ??????Rr }
			incr := 32;
			tcolorindexes := 16;
			tcolorvalues := 16;
			END
		END; { CASE }

	{ Fill palette arrays. }
	i := 0;
	b := 0;
	WHILE (b < 64) DO
		BEGIN
		g := 0;
		WHILE (g < 64) DO
			BEGIN
			r := 0;
			WHILE (r < 64) DO
				BEGIN
				long_colors[i] := rgb( r, g, b );
				{ Special case: 6 bits for 16 colors (RGBI).
				  If both bits are on for any color, intensity is on.
				  If one bit is set for a color, that color is on.
				}
				IF (incr = 32) THEN
					long_colors[i+8] := long_colors[i] OR ( long_colors[i] SHR 1 );
				Inc( i );
				Inc( r, incr );
				END;
			Inc( g, incr );
			END;
		Inc( b, incr );
		END;

	long_colors[tcolorvalues - 1] := _BrightWhite;
	nextcolorvalue( default );

	home;
END; { initturtle }

{ ============================== home ==================================
  Resets turtle defaults. This procedure can be called if you have
  not changed the video mode, but you want to put the turtle back in
  the center of the window and restore all defaults. For example, you can
  change the absolute window corners and then call it to set a new
  turtle window.

  Params: vc - pointer to videoconfig structure

}
PROCEDURE home;
VAR
	prev : LongInt;

BEGIN

	_SetViewport( tc.x_left, tc.y_top, tc.x_right, tc.y_bottom );
	tmaxy := 500.0;
	tmaxx := tmaxy * TRatioYX;

	_SetWindow( False, -tmaxx, -tmaxy, tmaxx, tmaxy );
	IF (_GrStatus <> _GrOk) THEN
		BEGIN
		tc.stat := False;
		Exit;
		END;

	tc.xcur := 0.0;
	tc.ycur := 0.0;
	_MoveTo_w( tc.xcur, tc.ycur );
	turnto( 0 );
	pendown( True );
	fillon( False );

	prev := _RemapPalette( tcolorindexes - 1, _BrightWhite );
	bordercolor( tcolorindexes - 1 );
	pencolor( tcolorindexes - 1 );

END; { home }

{ ============================== pendown ==================================

  Sets the visibility of the pen used by Move and MoveTo.

  Params: pen_on - True or False
}
PROCEDURE pendown( pen_on : Boolean );
BEGIN
	tc.pen_on := pen_on;
END;  { pendown }

{ ============================== penstate ==================================
  Gets the visibility of the pen used by Move and MoveTo.

  Return: True or False
}
FUNCTION penstate : Boolean;
BEGIN
	penstate := tc.pen_on;
END;  { penstate }

{ ============================== fillon ==================================
  FillOn - Sets the state of Filling figures such as Rectangle,
  Circle, and Ellipse.

  Params: fill_on - True or False
}
PROCEDURE fillon( fill_on : Boolean );
BEGIN
	IF fill_on THEN
		tc.fill_on := _GFillInterior
	ELSE
		tc.fill_on := _GBorder;
END;  { fillon }

{ ============================== fillstate ==================================
  Gets the state of Painting figures such as Rectangle,
  Circle, and Ellipse.

  Return: True or False
}
FUNCTION fillstate : Boolean;
BEGIN
	IF (tc.fill_on = _GBorder) THEN
		fillstate := False
	ELSE
		fillstate := True;
END;  { fillstate }

{ ============================== pencolor ==================================
 Sets the color index of the pen.

  Params: cur_index - a color index
}
PROCEDURE pencolor( cur_index : Integer );
BEGIN
	tc.cur_index := cur_index;
	_SetColor( tc.cur_index );
END;  { pencolor }

{ ============================== getpencolor  ===========================
  Gets the color index of the pen.

  Return: current color index
}
FUNCTION getpencolor : Integer;
BEGIN
	getpencolor := tc.cur_index;
END;  { getpencolor }

{ ============================== bordercolor  ===========================
  BorderColor - Sets the color index of the border that will be recognized
  by fills.

  Params: border_col - any color index
}
PROCEDURE bordercolor( border : Integer );
BEGIN
	tc.border_col := border;
END;   { bordercolor }

{ ========================== getbordercolor ============================
  Gets the color index of the border that will be recognized by fills.

  Return: current border color index
}
FUNCTION getbordercolor : Integer;
BEGIN
	getbordercolor := tc.border_col;
END;  { getbordercolor }

{ ============================== turn ==================================
  Sets a new direction relative to the current direction.

  Params: cur_angle - a positive (clockwise) or negative (counterclockwise)
			angle in degrees
}
PROCEDURE turn( cur_angle : degree );
BEGIN
	tc.cur_angle := (tc.cur_angle + cur_angle) MOD circumference;
END;  { turn }


{ ============================== turnto ==================================
  Sets a new absolute direction.

  Params: cur_angle - a positive (clockwise) or negative (counterclockwise)
			angle in degrees (0 points to 12 o'clock)

  Uses:   tc
}
PROCEDURE turnto( cur_angle : degree );
BEGIN
	IF (cur_angle < 0) THEN
		tc.cur_angle := circumference - (cur_angle MOD circumference)
	ELSE
		tc.cur_angle := cur_angle MOD circumference;
END;  { turnto }


{ ============================== getturn ==================================
  Gets the current absolute angle.

  Return: Angle between 0 and 359
}
FUNCTION getturn : degree;
BEGIN
	getturn := tc.cur_angle;
END;  { getturn }


{ ============================== move ==================================
  Moves from the current position in the current direction for a
  specified distance. A line is drawn if the pen is down. The current
  position is reset to the destination.

  Params: dxy - difference between current xy and new xy
}
PROCEDURE move( dxy : Double );
VAR
	dx, dy, angt : Double;

BEGIN
	angt := (tc.cur_angle - 90) * (Pi / halfcircumference);
	dx := dxy * Cos( angt );
	dy := dxy * Sin( angt );

	IF tc.pen_on THEN
		_LineTo_w( tc.xcur + dx, tc.ycur + dy )
	ELSE
		_MoveTo_w( tc.xcur + dx, tc.ycur + dy );

	tc.xcur := tc.xcur + dx;
	tc.ycur := tc.ycur + dy;

	IF onscreen( tc.xcur, tmaxx, tc.ycur, tmaxy ) THEN
		tc.stat := True
	ELSE
		tc.stat := False;
END;  { move }

{ ============================== moveto ==================================
  Moves from the current position to a specified position. A
  line is drawn if the pen is down. The current position is reset to the
  destination. The current direction is not changed.

  Params: x and y - destination position
}
PROCEDURE moveto( x, y : Double );
BEGIN
	IF tc.pen_on THEN
		_LineTo_w( x, y )
	ELSE
		_MoveTo_w( x, y );
	tc.xcur := x;
	tc.ycur := y;
	IF onscreen( tc.xcur, tmaxx, tc.ycur, tmaxy ) THEN
		tc.stat := True
	ELSE
		tc.stat := False;
END;  { moveto }

{ ============================== poly ==================================
  Draws a polygon.

  Params: n_sides - count of polygon sides
		  side_len - distance of each side

  Return: 0 if any part of polygon is off screen, nonzero if on screen
}
PROCEDURE poly( n_sides : Integer; side_len : Double );
VAR
	i, angle   : Integer;
	on, pen_on : Boolean;

BEGIN
	on := True;
	pendown( True );
	pen_on := turtlestat;
	angle := Round( 360 / n_sides );

	FOR i := 1 TO n_sides DO
		BEGIN
		Move( side_len );
		on := on AND turtlestat;
		turn( angle );
		END;

	pendown( pen_on );
	tc.stat := on;
END;  { poly }

{ ============================== nextcolorindex ========================
  Rotate to next color index. First attribute (normally background) and
  last attribute (white) are skipped.

  Params: cur_index - Specify DEFAULT to use color index from last call,
			or specify a new color to rotate from

  Return: rotated color index

  Uses:   tc
}
FUNCTION nextcolorindex( cur_index : Integer ) : Integer;
CONST
	prev_index : Integer = 0;

BEGIN
	{ Assign new current value if supplied. }
	IF (cur_index <> default) THEN
		prev_index := cur_index;

	{ Toggle for 2-color modes; rotate for multi-color modes. }

	IF (tcolorindexes = 2) THEN
		BEGIN
		prev_index := NOT prev_index;
		nextcolorindex := prev_index;
		END
	ELSE
		BEGIN
		Inc( prev_index );
		prev_index := prev_index MOD (tcolorindexes - 1);
		nextcolorindex := prev_index;
		END;
END; { nextcolorindex }

{ =========================== nextcolorvalue ===========================
  Rotate to next color value for adapters (EGA and higher) that support
  remappable palettes.

  Params: action - DEFAULT (rotate all) or LIMITED (rotate first
				   14 only)
}
PROCEDURE nextcolorvalue( action : Integer );
CONST
	cur_val   : LongInt = 1;
	cur_index : Integer = 1;
VAR
	temp_val, i : Integer;
	prev    : LongInt;

BEGIN

	{ Ignore modes with no palette values. }

	IF ((NOT tc.palette_on) OR (tcolorvalues = 0)) THEN
		Exit;

	{ Increment and rotate color value index. }
	Inc( cur_val );
	temp_val := cur_val MOD (tcolorvalues - 2) + 1;

	{ DEFAULT - Remap all color indexes, 14 at a time. For most modes,
	  this is all the indexes except first and last. For 256-color
	  mode, rotating all available indexes would be too slow.
	}
	IF (action = default) THEN
		FOR i := 1 TO 14 DO
			BEGIN
			prev := _RemapPalette( (cur_index MOD (tcolorindexes - 2 ) ) + 1,
								   long_colors[(temp_val MOD (tcolorvalues - 2)) + 1] );
			Inc( cur_index );
			Inc( temp_val );
			END
	{ LIMITED - Rotate only the first 14 color indexes. }
	ELSE
		FOR i := 1 TO 14 DO
			BEGIN
			prev := _RemapPalette( i,
						long_colors[(temp_val MOD (tcolorvalues - 1)) + 1] );
			Inc( temp_val );
			END;

END; { nextcolorvalue }

{ =============================== circle ===========================
  Put a circle with radius <r> at current location.
}
PROCEDURE circle( r : Double );
BEGIN
	_Ellipse_w( tc.fill_on, tc.xcur - r, tc.ycur - r,
						   tc.xcur + r, tc.ycur + r );
	tc.stat := (_GrStatus = _GrOk);
END;  { circle }

{ ============================== ellipse==================================
  Puts  an ellipse with width <w> and height <h> at current location.
}
PROCEDURE ellipse( w, h : Double );
BEGIN
	_Ellipse_w( tc.fill_on, tc.xcur - (w / 2), tc.ycur - (h / 2),
						   tc.xcur + (w / 2), tc.ycur + (h / 2) );
	tc.stat := (_GrStatus = _GrOk);
END;  { ellipse }

{ ============================== rectangle ==================================
  Puts the center of a rectangle with width <w> and height <h>
  at current location.
}
PROCEDURE rectangle( w, h : Double );
BEGIN
	_Rectangle_w( tc.fill_on, tc.xcur - (w / 2), tc.ycur - (h / 2),
							 tc.xcur + (w / 2), tc.ycur + (h / 2) );
	tc.stat := (_GrStatus = _GrOk);
END;  { rectangle }

{ ============================== imagesize ============================
  Gets the size of an image with width <w> and height <h>
  with left-top at current location.
}
FUNCTION imagesize( w, h : Double ) : LongInt;
BEGIN
	imagesize := _ImageSize_w( tc.xcur,     tc.ycur,
							   tc.xcur + w, tc.ycur + h );
	tc.stat := (_GrStatus = _GrOk);
END;   { imagesize }

{ ============================== getimage ==============================
  Gets an image with width <w> and height <h> with left-top
  at current location. Returns image buffer.
}
PROCEDURE getimage( w, h : Double; VAR buf );
BEGIN
	_GetImage_w( tc.xcur, tc.ycur, tc.xcur + w, tc.ycur + h, buf );
	tc.stat := (_GrStatus = _GrOk);
END;  { getimage }

{ ============================== putimage ==================================
  Puts the top-left corner of a specified image at current location
  using a specified action (_GPSET, _GPRESET, _GAND, _GOR, _GXOR).
}
PROCEDURE putimage( VAR buf; act : Integer );
BEGIN
	_PutImage_w( tc.xcur, tc.ycur, buf, act );
	tc.stat := (_GrStatus = _GrOk);
END;   { putimage }

{ ============================== paint ================================
  Paints from the current location to the border.
}
PROCEDURE paint;
BEGIN
	_FloodFill_w( tc.xcur, tc.ycur, tc.border_col );
	tc.stat := (_GrStatus = _GrOk);
END;  { paint }

{ ============================== gettwindow ==============================
  Returns the coordinates of the turtle window (viewport).
}
PROCEDURE gettwindow( VAR Left, Top, Right, Bottom : Integer );
BEGIN
	Left    := tc.x_left;
	Right   := tc.x_right;
	Top     := tc.y_top;
	Bottom  := tc.y_bottom;
END;    { gettwindow }

{ ============================== settwindow ==============================
  Sets the coordinates of the turtle window (viewport) .
}
PROCEDURE settwindow( Left, Top, Right, Bottom : Integer );
BEGIN
	tc.x_left   := Left;
	tc.x_right  := Right;
	tc.y_top    := Top;
	tc.y_bottom    := Bottom;
	_SetViewport( tc.x_left, tc.y_top, tc.x_right, tc.y_bottom );
	tc.stat := (_GrStatus = _GrOk);

END;  { settwindow }

{ ============================== tunit ==============================
  Returns the value of a turtle unit.
}
FUNCTION tunit : Double;
VAR
	xy1, xy2  : _WXYCoord;

BEGIN
	_GetWindowCoord( 1, 1, xy1 );
	_GetWindowCoord( 1, 2, xy2 );
	tunit := xy2.Wy - xy1.Wy;
END;   { tunit }

{ ============================== tcurx ==============================
  Returns the current x coordinate.
}
FUNCTION tcurx : Double;
BEGIN
	tcurx := tc.xcur;
END;  { tcurx }

{ ============================== tcury ==============================
  Returns the current y-coordinate.
}
FUNCTION tcury : Double;
BEGIN
	tcury := tc.ycur;
END;  { tcury }

END. { UNIT }