--***********************************************************************
--									*
--									*
--   This software was written by Bevin Brett, of Digital Equipment	*
--   Corporation.							*
--									*
--   Digital assumes no responsibility AT ALL for the use or reliability*
--   of this software.							*
--									*
--   Redistribution and use in source and binary forms are permitted	*
--   provided that the above copyright notice and this paragraph are	*
--   duplicated in all such forms and that any documentation,		*
--   advertising materials, and other materials related to such		*
--   distribution and use acknowledge that the software was developed	*
--   by Digital Equipment Corporation. The name of Digital Equipment	*
--   Corporation may not be used to endorse or promote products derived	*
--   from this software without specific prior written permission.	*
--									*
--   THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR	*
--   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED	*
--   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.*
--									*
--***********************************************************************

-- modified for use with Adabindx 10.8.1997
-- Hans-Frieder Vogt (vogt@ilaws6.luftfahrt.uni-stuttgart.de)

with COLORS, GRAPHICS_WINDOW_MANAGER, TEXT_IO, TOPO_SORT;
use  COLORS, GRAPHICS_WINDOW_MANAGER, TEXT_IO;
procedure DRAW_SHAPE(
    SHAPE	    : SHAPES.SHAPE;
    ROTATE_ABOUT_0  : UNITS.RADIANS;
    TRANSLATE_FROM_0: PLACES.VECTOR) is

    use SHAPES, UNITS, PLACES;

    SIN : constant FLOAT := UNITS.SIN(ROTATE_ABOUT_0);
    COS : constant FLOAT := UNITS.COS(ROTATE_ABOUT_0);

    procedure ROTATE(FROM : VECTOR; TO : in out VECTOR) is
    begin
	TO.I := FROM.I*COS - FROM.J*SIN;
	TO.J := FROM.I*SIN + FROM.J*COS;
	TO.K := FROM.K;
    end;

    procedure TRANSLATE(V : in out VECTOR) is
    begin
	ADD(TRANSLATE_FROM_0, V);
    end;

    procedure PROJECT(
	FROM  : VECTOR;
	POINT : out GRAPHICS_WINDOW_MANAGER.POINT_TYPE) is
    begin
	POINT := (X => POINT_AXIS_TYPE(0.5+FLOAT(FROM.J)/FLOAT(FROM.I)),
		  Y => POINT_AXIS_TYPE(    FLOAT(FROM.K)/FLOAT(FROM.I)));
    exception
	when others =>
	    PUT_LINE("A point is out of view");
	    PUT("    FROM =>");
	    PUT(" (I => " & Float'Image (FLOAT(FROM.I)));
	    PUT(", J => " & Float'Image (FLOAT(FROM.J)));
	    PUT(", K => " & Float'Image (FLOAT(FROM.K)));
	    PUT_LINE(");");
	    raise PROGRAM_ERROR;
    end;

    package DEPTH_PKG is
	type DEPTH is private;
	type HANDLE is private;

	DEFAULT_DEPTH : constant DEPTH;

	procedure PUT(DEPTH : DEPTH_PKG.DEPTH);

	procedure INIT   (
	    V      : VECTOR;
	    P      : POINT_TYPE;
	    HANDLE : out DEPTH_PKG.HANDLE);

	procedure COMBINE(
	    V 	   : VECTOR;
	    P      : POINT_TYPE;
	    HANDLE : in out DEPTH_PKG.HANDLE);

	function BEST(HANDLE : DEPTH_PKG.HANDLE) return DEPTH;

	function MAY_PRECEDE      (DEPTH1, DEPTH2 : DEPTH) return BOOLEAN;
	function GUESS_MAY_PRECEDE(DEPTH1, DEPTH2 : DEPTH) return BOOLEAN;

   private
	type DEPTH is
	    record
		MIN, MAX, GUESS : COORDINATE;
		MIN_I, MAX_I    : COORDINATE;
		MIN_J, MAX_J	: COORDINATE;
		MIN_K, MAX_K    : COORDINATE;
		MIN_X, MAX_X    : POINT_AXIS_TYPE;
		MIN_Y, MAX_Y	: POINT_AXIS_TYPE;
	    end record;

	type HANDLE is
	    record
		BEST : DEPTH;
		SUM  : VECTOR;
    	    end record;

	DEFAULT_DEPTH : constant DEPTH
		:= (MIN_X|MAX_X|MIN_Y|MAX_Y => 0.0, others => 0.0);
    end;
    use DEPTH_PKG;

    package body DEPTH_PKG is

	procedure PUT(DEPTH : DEPTH_PKG.DEPTH) is
	begin
	    PUT("DEPTH'(MIN=>" & Float'Image (FLOAT(DEPTH.MIN)));
	    PUT(",MAX=>"       & Float'Image (FLOAT(DEPTH.MAX)));
	    PUT(",GSS=>"       & Float'Image (FLOAT(DEPTH.GUESS)));
	end;

	function F(V : VECTOR) return COORDINATE is
	begin
	    return V.I**2+V.J**2+V.K**2;
	end;

	procedure INIT(
	    V 	   : VECTOR;
	    P      : POINT_TYPE;
	    HANDLE : out DEPTH_PKG.HANDLE)
	is
	    F_V : constant COORDINATE := F(V);
	    BEST : DEPTH renames HANDLE.BEST;
	begin
	    BEST.MIN := F_V;
	    BEST.MAX := F_V;

	    BEST.MIN_I := V.I; BEST.MAX_I := V.I;
	    BEST.MIN_J := V.J; BEST.MAX_J := V.J;
	    BEST.MIN_K := V.K; BEST.MAX_K := V.K;
	    BEST.MIN_X := P.X; BEST.MAX_X := P.X;
	    BEST.MIN_Y := P.Y; BEST.MAX_Y := P.Y;

	    BEST.GUESS := F_V;
	    HANDLE.SUM := V;
	end;

	generic
	    type SOME_FLOAT is digits <>;
	procedure GEN_ADJUST_MIN_MAX(V : in SOME_FLOAT;
	    MIN_V, MAX_V : in out SOME_FLOAT);

	procedure GEN_ADJUST_MIN_MAX(V : in SOME_FLOAT;
	    MIN_V, MAX_V : in out SOME_FLOAT)
	is
	    function MIN(LHS,RHS : SOME_FLOAT) return SOME_FLOAT is
	    begin
		if LHS < RHS then return LHS; else return RHS; end if;
	    end;
    	    function MAX(LHS,RHS : SOME_FLOAT) return SOME_FLOAT is
	    begin
		if LHS > RHS then return LHS; else return RHS; end if;
	    end;
    	begin
	    MIN_V := MIN(MIN_V, V);
	    MAX_V := MAX(MAX_V, V);
	end;

	procedure ADJUST_MIN_MAX is new GEN_ADJUST_MIN_MAX(COORDINATE);
	procedure ADJUST_MIN_MAX is new GEN_ADJUST_MIN_MAX(POINT_AXIS_TYPE);

	procedure COMBINE(
	    V      : VECTOR;
	    P      : POINT_TYPE;
	    HANDLE : in out DEPTH_PKG.HANDLE)
	is
	    F_V : constant COORDINATE := F(V);
	    BEST : DEPTH renames HANDLE.BEST;
	begin
	    ADJUST_MIN_MAX(F_V,     BEST.MIN,   BEST.MAX);
	    ADJUST_MIN_MAX(abs V.I, BEST.MIN_I, BEST.MAX_I);
	    ADJUST_MIN_MAX(abs V.J, BEST.MIN_J, BEST.MAX_J);
	    ADJUST_MIN_MAX(abs V.K, BEST.MIN_K, BEST.MAX_K);
	    ADJUST_MIN_MAX(P.X    , BEST.MIN_X, BEST.MAX_X);
	    ADJUST_MIN_MAX(P.Y    , BEST.MIN_Y, BEST.MAX_Y);
	    HANDLE.SUM := HANDLE.SUM + V;
	    BEST.GUESS := F(HANDLE.SUM);
	end;

	function BEST(HANDLE : DEPTH_PKG.HANDLE) return DEPTH is
	begin
	    return HANDLE.BEST;
	end;

	function MAY_PRECEDE(DEPTH1, DEPTH2 : DEPTH) return BOOLEAN is
	begin
	    if DEPTH1.MIN_I >= DEPTH2.MAX_I then return TRUE; end if;
	    --if DEPTH1.MIN_J >= DEPTH2.MAX_J then return TRUE; end if;
	    if DEPTH1.MIN_K >= DEPTH2.MAX_K then return TRUE; end if;

	    if DEPTH1.MIN_X >= DEPTH2.MAX_X then return TRUE; end if;
	    if DEPTH1.MAX_X <= DEPTH2.MIN_X then return TRUE; end if;

	    if DEPTH1.MIN_Y >= DEPTH2.MAX_Y then return TRUE; end if;
	    if DEPTH1.MAX_Y <= DEPTH2.MIN_Y then return TRUE; end if;

	    if DEPTH1.MIN   >  DEPTH2.MAX+0.5 then return TRUE; end if;

	    return FALSE;
	end;

	function GUESS_MAY_PRECEDE(DEPTH1, DEPTH2 : DEPTH) return BOOLEAN is
	begin
	    return DEPTH1.GUESS > DEPTH2.GUESS;
	end;
    end;

    procedure PROJECT_FACE(
	FACE 	: SHAPES.FACE;
	VISIBLE	: out BOOLEAN;
	NORMAL 	: in out VECTOR; 
	POINTS 	: in out POINTS_TYPE;
	VECTORS : in out LIST_OF_VECTORS;
	DEPTH  	: out DEPTH_PKG.DEPTH)
    is
	N : VECTOR renames NORMAL;
	FIRST : VECTOR renames VECTORS(VECTORS'first);
    begin
	-- rotate the NORMAL
	ROTATE(FACE.NORMAL, N);

	-- rotate and translate the first corner
	ROTATE(FACE.CORNERS(1), FIRST);
	TRANSLATE(FIRST);

	-- decide if visible
	VISIBLE := TRUE;
	if N&FIRST >= 0.0 then
	    DEPTH := DEFAULT_DEPTH;
	    VISIBLE := FALSE;
	    return;
	end if;

	-- project and draw the face
	declare
	    HANDLE : DEPTH_PKG.HANDLE;
	begin
	    -- project the first corner
	    PROJECT(FIRST, POINTS(POINTS'first));

	    INIT(FIRST, POINTS(POINTS'first), HANDLE);

	    -- project the rest also after rotate and translate
	    for I in 2..FACE.CORNERS'last loop
		declare
		    REST : VECTOR renames VECTORS(VECTORS'first+I-1);
		begin
		    ROTATE(FACE.CORNERS(I), REST);
		    TRANSLATE(REST);
    		    PROJECT(REST, POINTS(POINTS'first+I-1));
    		    COMBINE(REST, POINTS(POINTS'first+I-1), HANDLE);
		end;
	    end loop;

	    -- use BEST as the depth
	    DEPTH := BEST(HANDLE);
	end;
    end;

begin
    -- count up the points
    declare
        NUMBER_OF_POINTS : NATURAL := 0;
    begin
        for I in SHAPE.FACES'range loop
	    NUMBER_OF_POINTS :=
		NUMBER_OF_POINTS + SHAPE.FACES(I).all.CORNERS'length;
	end loop;

        -- create the points
	declare
	    NEXT_POINT : NATURAL := 1;
	    POINTS : POINTS_TYPE(1..NUMBER_OF_POINTS);
	    VECTORS: LIST_OF_VECTORS(1..NUMBER_OF_POINTS);

	    type FACE_INFO is
		record
		    INDEX   : POSITIVE;
	    	    VISIBLE : BOOLEAN;
		    LO,HI   : POSITIVE;
		    FACE    : ACCESS_FACE;
		    DEPTH   : DEPTH_PKG.DEPTH;
		    NORMAL  : VECTOR;
		end record;

	    type FACES_INFO_TYPE is array(POSITIVE range <>) of FACE_INFO;
	    FACES_INFO : FACES_INFO_TYPE(SHAPE.FACES'range);
	    VF : INTEGER := FACES_INFO'first;

	begin
	    -- remember all the points for the visible faces
            for F in SHAPE.FACES'range loop
		FACES_INFO(VF).LO := NEXT_POINT;
		FACES_INFO(VF).HI :=
		    NEXT_POINT+SHAPE.FACES(F).NUMBER_OF_CORNERS-1;
	        PROJECT_FACE(SHAPE.FACES(F).all,
		    FACES_INFO(VF).VISIBLE,
		    FACES_INFO(VF).NORMAL,
		    POINTS(FACES_INFO(VF).LO..FACES_INFO(VF).HI),
		    VECTORS(FACES_INFO(VF).LO..FACES_INFO(VF).HI),
		    FACES_INFO(VF).DEPTH);
		if FACES_INFO(VF).VISIBLE then
		    FACES_INFO(VF).INDEX := VF;
		    FACES_INFO(VF).FACE := SHAPE.FACES(F);
		    NEXT_POINT := FACES_INFO(VF).HI + 1;
		    VF := VF+1;
		end if;
	    end loop;
	    VF := VF-1;

	    -- sort the visible faces by distance, furtherest first
	    declare

		function IN_FRONT_OF(LHS,RHS : FACE_INFO) return BOOLEAN is
		    L : LIST_OF_VECTORS renames VECTORS(LHS.LO..LHS.HI);
		    R : LIST_OF_VECTORS renames VECTORS(RHS.LO..RHS.HI);

		    FOR_ORIGIN : BOOLEAN;

		    AT_LEAST_ONE_NON_COPLANAR : BOOLEAN := FALSE;

		    BIAS : constant COORDINATE := 0.001;
		    SIGNED_BIAS : COORDINATE := 0.0;

		    function F(V : VECTOR) return BOOLEAN is
			P : COORDINATE := RHS.NORMAL&(V-R(R'first));
		    begin
			if abs P > BIAS then
			   AT_LEAST_ONE_NON_COPLANAR := TRUE;
			end if;
			return SIGNED_BIAS <= P;
		    end;

		begin
		    FOR_ORIGIN := F((0.0, 0.0, 0.0));

		    -- try  to cope with rounding errors of points in plane
		    if FOR_ORIGIN then
			SIGNED_BIAS := -BIAS;
		    else
			SIGNED_BIAS := +BIAS;
		    end if;

		    for I in L'range loop
			if F(L(I)) /= FOR_ORIGIN then return FALSE; end if;
		    end loop;

		    return AT_LEAST_ONE_NON_COPLANAR;
		end;

		function MAY_PRECEDE(LHS,RHS : FACE_INFO;
		    DESPARATE : BOOLEAN) return BOOLEAN is
		begin
		    if MAY_PRECEDE(LHS.DEPTH, RHS.DEPTH) then
			return TRUE;
		    end if;

		    if IN_FRONT_OF(RHS, LHS) then
			return TRUE;
		    end if;

		    if IN_FRONT_OF(LHS, RHS) then
			return FALSE;
		    end if;

		    if DESPARATE then
			return TRUE;
		    end if;

		    return GUESS_MAY_PRECEDE(LHS.DEPTH, RHS.DEPTH);
		end;

		procedure WARN is
		begin
		    null; -- PUT_LINE("*********** No suitable found **************");
		end;

		procedure PUT(V : VECTOR) is
		begin
		    PUT("(I=>"  & Float'Image (FLOAT(V.I)));
		    PUT(", J=>" & Float'Image (FLOAT(V.J)));
		    PUT(", K=>" & Float'Image (FLOAT(V.K)));
		    PUT(")");
		end;

		procedure PUT(ITEMS : LIST_OF_VECTORS) is
		begin
		    PUT("(");
		    for I in ITEMS'range loop
			PUT(ITEMS(I));
			if I /= ITEMS'last then PUT(","); end if;
		    end loop; 
		    PUT(")");
		end;

		procedure PUT(ITEMS : FACES_INFO_TYPE) is
		begin
		    for I in ITEMS'range loop
			PUT("FACE'(CORNERS=>");
			PUT(VECTORS(ITEMS(I).LO..ITEMS(I).HI));
			NEW_LINE;
			PUT("     ,DEPTH=>");
			PUT(ITEMS(I).DEPTH);
			PUT(")");
			NEW_LINE(2);
		    end loop;
		    NEW_LINE;
		end;
	
		package SORT_PKG is
		    new TOPO_SORT(
			ELEMENT		=> FACE_INFO,
			MAY_PRECEDE	=> MAY_PRECEDE,
			INDEX_TYPE	=> POSITIVE,
			ITEMS_TYPE	=> FACES_INFO_TYPE,
			PUT		=> PUT,
			WARN		=> WARN);

	    begin
		-- sort the elements
		SORT_PKG.SORT(FACES_INFO(FACES_INFO'first..VF));

	    end;

            -- draw the visible faces in the right order
	    for F in FACES_INFO'first..VF loop
	        FILL_CONVEX_POLYGON(
		    FACES_INFO(F).FACE.COLOR,
		    POINTS(FACES_INFO(F).LO..FACES_INFO(F).HI));
	    end loop;
	end;
    end;
end;