Virtual Reality Homebrewer's Handbook/vr.iso/vroom/vroom1.pas

Pascal/Delphi Source File | 1996-03-19 | 47KB | 1,503 lines

{------------------------------------------------}
{ File_Object_3d method implementations          }
{------------------------------------------------}

constructor file_object3d.Init(fname : titletype);
var f : text;
    temp_face : face_ptr;
    temp_vertex : vertex_ptr;
    nv, nf, nfv, vertexno : integer;
    count1, count2, count3 : integer;
    color : byte;
    x1, y1, z1, inten : real;
begin
     object3d.Init;
     assign(f,fname);
     reset(f);
     readln(f,nv);
     if nv<=0 then
     begin
          stop_graphics;
          if nv<=0 then writeln('Fatal file read error - number vertices is negative.')
          else writeln('Fatal file read error - not enough vertices to form a face.');
          halt;
     end;
     read(f,x1);
     read(f,y1);
     readln(f,z1);
     temp_vertex:=add_vertex(x1,y1,z1);
     reference_point.x:=real_to_fixed(x1);
     reference_point.y:=real_to_fixed(y1);
     reference_point.z:=real_to_fixed(z1);
     for count1:=2 to nv do
     begin
          read(f,x1);
          read(f,y1);
          readln(f,z1);
          temp_vertex:=add_vertex(x1,y1,z1);
     end;
     readln(f,nf);
     if nf<>0 then
     begin
          stop_graphics;
          writeln('Fatal file error - file check digit failure.');
          halt;
     end;
     readln(f,nf);
     if nf<=0 then
     begin
          stop_graphics;
          writeln('Fatal file error - no faces in file.');
          halt;
     end;
     for count1:=1 to nf do
     begin
          read(f,color);
          readln(f,inten);
          readln(f,nfv);
          if nfv<0 then
          begin
               stop_graphics;
               if nfv<=0 then writeln('Fatal file read error - number of face vertices is negative.');
               halt;
          end;
          if nfv>0 then
          begin
               new(temp_face);
               if (color<0) or (color>15) then
               begin
                    stop_graphics;
                    writeln('Error! - Face color outside range 0 to 15.');
               halt;
               end;
               temp_face^.colour:=color;
               if (inten<0) or (inten>1) then
               begin
                    stop_graphics;
                    writeln('Error! - Face intensity outside range 0 to 1.');
                    halt;
               end;
               temp_face^.next:=first_face;
               first_face:=temp_face;
               temp_face^.next_order:=first_list_face;
               first_list_face:=temp_face;
               temp_face^.intensity:=real_to_fixed(inten);
               temp_face^.Color:=temp_face^.Colour*16+trunc(temp_face^.intensity/65536*15+0.5);
               temp_face^.sort_z:=0;
               temp_face^.vertex1:=nil;
               for count2:=1 to nfv do
               begin
                    if count2=nfv then readln(f,vertexno) else read(f,vertexno);
                    if (vertexno<1) or (vertexno>nv) then
                    begin
                         stop_graphics;
                         writeln('Fatal file read error - trying to assign non-existant vertex.');
                         halt;
                    end;
                    temp_vertex:=first_vertex;
                    for count3:=1 to (nv-vertexno) do
                       temp_vertex:=temp_vertex^.next;
                    temp_face^.Add_Vertex(temp_vertex);
               end;
          end
          else
          begin
               writeln('File warning - no face vertices! Face ignored.');
          end;
          readln(f,vertexno);
          if vertexno<>0 then
          begin
               stop_graphics;
               writeln('Fatal file error - file check digit failure.');
               halt;
          end;
     end;
     readln(f,vertexno);
     if vertexno<>0 then
     begin
          stop_graphics;
          writeln('Fatal file error - file check digit failure.');
          halt;
     end;
     close(f);
     Build_Normals;
end;



{------------------------------------------------}
{ Copy_Object3d method implementations           }
{------------------------------------------------}

constructor copy_object3d.Init(source_object : object3d_ptr);
var first_vertex_copy, temp_vertex_copy : vertex_copy_ptr;
    source_vertex, copy_vertex : vertex_ptr;
    source_face, copy_face : face_ptr;
    last_face_vertex, source_face_vertex, copy_face_vertex : face_vertex_ptr;
begin
     if source_object=nil then
     begin
          stop_graphics;
          writeln('Trying to copy a nil object3d');
          halt;
     end;
     object3d.Init;
     lo.x:=source_object^.lo.x;
     lo.y:=source_object^.lo.y;
     lo.z:=source_object^.lo.z;
     hi.x:=source_object^.hi.x;
     hi.y:=source_object^.hi.y;
     hi.z:=source_object^.hi.z;
     reference_point.x:=source_object^.reference_point.x;
     reference_point.y:=source_object^.reference_point.y;
     reference_point.z:=source_object^.reference_point.z;
     first_vertex_copy:=nil;
     source_vertex:=source_object^.first_vertex;
     while source_vertex<>nil do
     begin
          new(copy_vertex);
          copy_vertex^.next:=first_vertex;
          first_vertex:=copy_vertex;
          with copy_vertex^ do
          begin
               screen.x:=source_vertex^.screen.x;
               screen.y:=source_vertex^.screen.y;
               screen.z:=source_vertex^.screen.z;
               world.x:=source_vertex^.world.x;
               world.y:=source_vertex^.world.y;
               world.z:=source_vertex^.world.z;
               clip:=source_vertex^.clip;
          end;
          new(temp_vertex_copy);
          temp_vertex_copy^.next:=first_vertex_copy;
          first_vertex_copy:=temp_vertex_copy;
          temp_vertex_copy^.old_vertex:=source_vertex;
          temp_vertex_copy^.new_vertex:=copy_vertex;
          source_vertex:=source_vertex^.next;
     end;

     source_face:=source_object^.first_face;
     while source_face<>nil do
     begin
          new(copy_face);
          copy_face^.next:=first_face;
          first_face:=copy_face;
          copy_face^.next_order:=first_list_face;
          first_list_face:=copy_face;
          copy_face^.intensity:=source_face^.intensity;
          copy_face^.Color:=source_face^.color;
          copy_face^.Colour:=source_face^.colour;
          copy_face^.sort_z:=source_face^.sort_z;
          copy_face^.seen:=source_face^.seen;
          copy_face^.normal.x:=source_face^.normal.x;
          copy_face^.normal.y:=source_face^.normal.y;
          copy_face^.normal.z:=source_face^.normal.z;
          copy_face^.this_fillproc:=source_face^.this_fillproc;
          copy_face^.two_d:=source_face^.two_d;
          copy_face^.vertex1:=nil;
          last_face_vertex:=nil;
          source_face_vertex:=source_face^.vertex1;
          while source_face_vertex<>nil do
          begin
               new(copy_face_vertex);
               copy_face_vertex^.next:=nil;
               if last_face_vertex<>nil then last_face_vertex^.next:=copy_face_vertex
               else copy_face^.vertex1:=copy_face_vertex;
               last_face_vertex:=copy_face_vertex;
               temp_vertex_copy:=first_vertex_copy;
               while (temp_vertex_copy^.next<>nil) and (temp_vertex_copy^.old_vertex<>source_face_vertex^.this_vertex)
                 do temp_vertex_copy:=temp_vertex_copy^.next;
               if temp_vertex_copy<>nil
                 then copy_face_vertex^.this_vertex:=temp_vertex_copy^.new_vertex
                 else copy_face_vertex^.this_vertex:=source_face_vertex^.this_vertex;
               source_face_vertex:=source_face_vertex^.next;
          end;
          source_face:=source_face^.next;
     end;

     temp_vertex_copy:=first_vertex_copy;
     while temp_vertex_copy<>nil do
     begin
          first_vertex_copy:=temp_vertex_copy^.next;
          dispose(temp_vertex_copy);
          temp_vertex_copy:=first_vertex_copy;
     end;
end;


{------------------------------------------------}
{ Face method implementations                    }
{------------------------------------------------}

constructor Face.Init(var owner : object3d; face_color : byte; inten : real);
begin
     next:=owner.first_face;
     owner.first_face:=@vertex1;
     next_order:=first_list_face;
     first_list_face:=@vertex1;
     if (face_color<0) or (face_color>15) then
     begin
          stop_graphics;
          writeln('Error! - Face color outside range 0 to 15.');
          halt;
     end;
     colour:=face_color;
     if (inten<0) or (inten>1) then
     begin
          stop_graphics;
          writeln('Error! - Face intensity outside range 0 to 1.');
          halt;
     end;
     intensity:=real_to_fixed(inten);
     Color:=Colour*16+trunc(intensity/65536*15+0.5);

     vertex1:=nil;
     d:=0;
     normal.x:=0;
     normal.y:=0;
     normal.z:=0;
     sort_z:=0;
     two_d:=false;
end;

procedure Face.Add_Vertex(this_vertex : vertex_ptr);
var temp_vertex : face_vertex_ptr;
begin
     if this_vertex=nil then exit;
     new(temp_vertex);
     temp_vertex^.next:=vertex1;
     temp_vertex^.this_vertex:=this_vertex;
     vertex1:=temp_vertex;
end;

procedure Face.Build_Normal;
var temp_face_vertex : face_vertex_ptr;
    nx, ny, nz : longint;
    length : longint;
    count : integer;
begin
     two_d:=false;
     nx:=0; ny:=0; nz:=0;
     temp_face_vertex:=vertex1;
     if temp_face_vertex=nil then
     begin
          stop_graphics;
          writeln('Fatal Error ! - Face has no vertices to build normal with.');
          halt;
     end;
     if temp_face_vertex^.next=nil then
     begin
          this_fillproc:=Fill_Face_Point;
          two_d:=true;
     end
     else
     if temp_face_vertex^.next^.next=nil then
     begin
          this_fillproc:=Fill_Face_Line;
          two_d:=true;
     end
     else
     begin
          while temp_face_vertex^.next<>nil do
          begin
               nx:=nx-FixedMul(temp_face_vertex^.this_vertex^.world.y-temp_face_vertex^.next^.this_vertex^.world.y,
                               temp_face_vertex^.this_vertex^.world.z+temp_face_vertex^.next^.this_vertex^.world.z);
               ny:=ny-FixedMul(temp_face_vertex^.this_vertex^.world.z-temp_face_vertex^.next^.this_vertex^.world.z,
                               temp_face_vertex^.this_vertex^.world.x+temp_face_vertex^.next^.this_vertex^.world.x);
               nz:=nz-FixedMul(temp_face_vertex^.this_vertex^.world.x-temp_face_vertex^.next^.this_vertex^.world.x,
                               temp_face_vertex^.this_vertex^.world.y+temp_face_vertex^.next^.this_vertex^.world.y);
               temp_face_vertex:=temp_face_vertex^.next;
          end;
          nx:=nx-FixedMul(temp_face_vertex^.this_vertex^.world.y-vertex1^.this_vertex^.world.y,
                          temp_face_vertex^.this_vertex^.world.z+vertex1^.this_vertex^.world.z);
          ny:=ny-FixedMul(temp_face_vertex^.this_vertex^.world.z-vertex1^.this_vertex^.world.z,
                          temp_face_vertex^.this_vertex^.world.x+vertex1^.this_vertex^.world.x);
          nz:=nz-FixedMul(temp_face_vertex^.this_vertex^.world.x-vertex1^.this_vertex^.world.x,
                          temp_face_vertex^.this_vertex^.world.y+vertex1^.this_vertex^.world.y);
          if (nx=0) and (ny=0) and (nz=0) then
          begin
               two_d:=true;
               this_fillproc:=Fill_Face_Line;
          end
          else
              this_fillproc:=Fill_Face;
     end;

     if not(two_d) then
     begin
           length:=real_to_fixed(sqrt(sqr(nx/65536)+sqr(ny/65536)+sqr(nz/65536)));
           normal.x:=FixedDiv(nx,length);
           normal.y:=FixedDiv(ny,length);
           normal.z:=FixedDiv(nz,length);
     end
     else
     begin
          normal.x:=0; normal.y:=0; normal.z:=0;
     end;
     {n.p=D, but I don't need it yet so I've left it}
     Shading;
end;

procedure Face.Unit_Normal;
var length : longint;
begin
      if two_d then exit;
      length:=real_to_fixed(sqrt(sqr(normal.x/65536)+sqr(normal.y/65536)+sqr(normal.z/65536)));
      normal.x:=FixedDiv(normal.x,length);
      normal.y:=FixedDiv(normal.y,length);
      normal.z:=FixedDiv(normal.z,length);
end;

procedure Face.Shading;
var Intens, CosTheta : longint;
begin
     if not(two_d) then
     begin
          CosTheta:=FixedMul(normal.x,light.x)+FixedMul(normal.y,light.y)+FixedMul(normal.z,light.z);
          if CosTheta<0 then CosTheta:=0;
          Intens:=Ambient_Intensity+FixedMul(Light_Intensity,CosTheta);
          if Intens>65536 then Intens:=65536;
     end
     else
     begin
          Intens:=Ambient_Intensity+Light_Intensity;
          if Intens>65536 then Intens:=65536;
     end;
     Intens:=FixedMul(Intens,intensity);
     Color:=Colour*16+trunc(intens/65536*15+0.5);
end;

procedure Face.Fill;
begin
     this_fillproc(@vertex1);
end;

destructor Face.Done;
var temp_face : face_ptr;
    temp_face_vertex1, temp_face_vertex2 : face_vertex_ptr;
    temp_obj : object3d_ptr;
begin
     {Remove from sorted face list}
     if first_list_face=@vertex1 then first_list_face:=next_order
     else
     begin
          temp_face:=first_list_face;
          while (temp_face<>nil) and (temp_face^.next_order<>@vertex1) do
                temp_face:=temp_face^.next_order;
          if temp_face<>nil then temp_face^.next_order:=next_order;
     end;

     temp_face_vertex1:=vertex1;
     while temp_face_vertex1<>nil do
     begin
          temp_face_vertex2:=temp_face_vertex1^.next;
          dispose(temp_face_vertex1);
          temp_face_vertex1:=temp_face_vertex2;
     end;
end;


{------------------------------------------------}
{ Timed_Xform method implementations             }
{------------------------------------------------}

constructor timed_Xform.Init(this_object : object3d_ptr; start, duration : real);
begin
     this_ob:=this_object;
     t_start:=start;
     t_last:=start;
     if duration=infinity then t_end:=duration else t_end:=t_last+duration;
     next:=first_timed_xform;
     first_timed_xform:=@t_start;
end;

procedure timed_Xform.Update;
begin
end;

destructor timed_Xform.Done;
var temp : timed_Xform_ptr;
begin
     if first_timed_xform=@t_start then first_timed_xform:=next
     else
     begin
          temp:=first_timed_xform;
          while (temp<>nil) and (temp^.next<>@t_start) do temp:=temp^.next;
          if temp<>nil then temp^.next:=next;
     end;
end;


constructor timed_rotX.Init(this_object : object3d_ptr ; start, duration, dtheta : real);
begin
     timed_Xform.Init(this_object,start, duration);
     dth:=dtheta;
end;

procedure timed_rotX.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateX(theta);
     end;
end;

procedure timed_rotY.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateY(theta);
     end;
end;

procedure timed_rotZ.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateZ(theta);
     end;
end;

constructor timed_rotX_About.Init(this_object : object3d_ptr ; start, duration, dtheta, x1, y1, z1 : real);
begin
     timed_Xform.Init(this_object,start, duration);
     dth:=dtheta;
     X:=x1; Y:=y1; Z:=z1;
end;

procedure timed_rotX_About.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateX_About(theta,x,y,z);
     end;
end;

procedure timed_rotY_About.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateY_About(theta,x,y,z);
     end;
end;

procedure timed_rotZ_About.Update;
var theta : real;
begin
     theta:=round(dth*10*(graphics_time^-t_last))/10;
     if abs(theta)>0 then
     begin
          t_last:=t_last+theta/dth;
          this_ob^.RotateZ_About(theta,x,y,z);
     end;
end;

constructor timed_scale.Init(this_object : object3d_ptr ; start, duration, sx1, sy1, sz1 : real);
begin
     stop_graphics;
     writeln('Timed Scale is not implemented yet !!');
     halt;
end;

procedure timed_scale.Update;
begin
end;

constructor timed_scale_About.Init(this_object : object3d_ptr ; start, duration, sx1, sy1, sz1, x1, y1, z1 : real);
begin
     stop_graphics;
     writeln('Timed Scale About is not implemented yet !!');
     halt;
end;

procedure timed_scale_About.Update;
begin
end;

constructor timed_translate.Init(this_object : object3d_ptr; start, duration, x1, y1, z1 : real);
begin
     timed_Xform.Init(this_object,start, duration);
     X:=x1; Y:=y1; Z:=z1;
end;

procedure timed_translate.Update;
var dt : real;
begin
     dt:=graphics_time^-t_last;
     this_ob^.translate(dt*X,dt*Y,dt*Z);
     t_last:=graphics_time^;
end;

{------------------------------------------------}
{ General procedures                             }
{------------------------------------------------}

procedure Init_System;
var junk : integer;
    r : registers;
    c : char;
begin
     first_object:=nil;
     first_list_face:=nil;
     first_timed_Xform:=nil;
     redraw_all:=true;
     timed_xforms_separately:=false;
     this_keyproc:=NulKeyProc;
     any_textproc:=false;
     cursor2D_mode:=false;
     Set_Default_Cursor2D;
     Cursor_x:=320;
     Cursor_y:=100;
     viewpoint.x:=0;
     viewpoint.y:=0;
     viewpoint.z:=0;
     azimuth:=0;
     colatitude:=0;
     speed:=65536;
     setviewpoint.x:=0;
     setviewpoint.y:=0;
     setviewpoint.z:=0;
     setazimuth:=0;
     setcolatitude:=0;
     setspeed:=65536;
     Set_Window(-20,-15,20,15);
     eye_screen_distance:=int_to_fixed(300);
     hither:=1;
     yon:=10000;
     picture_num:=0;
     r.ax:=$1130;
     r.bh:=$3;
     intr($10,r);
     font_segment:=r.es;
     font_offset:=r.bp;
     assign(output,'OUTPUT.LOG');
     rewrite(output);
     set_background_colour(0,0);
     Start_Graphics;
     Set_Palette;
     Init_CosTable;
     Ambient_Intensity:=65536;
     Light_Intensity:=0;
     Light.x:=0; Light.y:=0; Light.z:=0;
     ReadMouseCounter(junk,junk);
     sort_type:=4;
     write_text_at(7,9, '╔═══════════════════════════╗',5,1,3,1);
     write_text_at(7,10,'║ VROOM VR Graphics Toolbox ║',5,1,3,1);
     write_text_at(7,11,'║',5,1,3,1);
     write_text_at(7+28,11,'║',5,1,3,1);
     write_text_at(8,11,'     by Robin Hollands     ',0,1,3,1);
     write_text_at(7,12,'╚═══════════════════════════╝',5,1,3,1);
     write_text_at(7,15,'   Press a key to continue   ',2,1,0,-1);
     show_page(screen_page_offset);
     c:=ReadKey;
     write_text_at(7,15,'Loading world - please wait...',2,1,0,0);
end;

procedure Sort_by_Nearest_Point;
begin
     sort_type:=2;
end;

procedure Sort_by_Furthest_Point;
begin
     sort_type:=1;
end;

procedure Sort_by_Middle_Point;
begin
     sort_type:=4;
end;

procedure Set_Window(wl,wb,wr,wt : real);
var sxr,syr,rxr,ryr : real;
begin
     Sx:=real_to_fixed((Dr-Dl)/(Wr-Wl));
     Sy:=real_to_fixed((Dt-Db)/(Wt-Wb));
     Rx:=real_to_fixed(Dl-Wl*(Dr-Dl)/(Wr-Wl));
     Ry:=real_to_fixed(Db-Wb*(Dt-Db)/(Wt-Wb));
end;

procedure Set_World_to_View(x,y,z : longint; azimuth_in, colatitude_in, roll_in : real);
var s1, s2, c1, c2 : longint;
    a,c,r : integer;
begin
     a:=-round(azimuth_in*10);
     c:=-round(colatitude_in*10);
     CosSin(a,c1,s1);
     CosSin(c,c2,s2);
     w2v.data(s1, fixedmul(-c1,s2),  fixedmul(-c1,c2), 0,
                      c1, fixedmul(s1,s2),   fixedmul(s1,c2), 0,
                      0,   c2,     -s2,    0,
                      fixedmul(-x,s1)-fixedmul(y,c1),
                      fixedmul(fixedmul(x,c1),s2)-fixedmul(fixedmul(y,s1),s2)-fixedmul(z,c2),
                      fixedmul(fixedmul(x,c1),c2)-fixedmul(fixedmul(y,s1),c2)+fixedmul(z,s2),
                      65536);
     redraw_all:=true;
end;

procedure Set_View(x,y,z, azimuth_in, colatitude_in, roll_in : real);
var r, c : integer;
begin
     x_pos:=x;
     y_pos:=y;
     z_pos:=z;
     viewpoint.x:=real_to_fixed(x);
     viewpoint.y:=real_to_fixed(y);
     viewpoint.z:=real_to_fixed(z);
     azimuth:=azimuth_in;
     colatitude:=colatitude_in;
     Set_World_to_View(viewpoint.x,viewpoint.y,viewpoint.z,azimuth,colatitude,roll);
     main_matrix:=w2v;
end;

procedure Redraw_Scene;
var temp_face : face_ptr;
begin
     if screen_page_offset=page0 then screen_page_offset:=page1 else screen_page_offset:=page0;
     if not(timed_xforms_separately) then Apply_Timed_Transforms;
     Transform_World_to_Screen;
     ClGSc;
     Clip_Stuff;
     Sort_Face_List;

     temp_face:=first_list_face;
     while temp_face<>nil do
     begin
          if temp_face^.seen then temp_face^.Fill;
          temp_face:=temp_face^.next_order;
     end;

     if any_textproc then this_textproc;
     if cursor2D_mode then Draw_Cursor2D(cursor_x div 2, trunc((cursor_y * 1.2)+0.5));
     Show_Page(screen_page_offset);

     redraw_all:=false;
end;

procedure Transform_World_to_Screen;
var this_ob : object3d_ptr;
begin
     this_ob:=first_object;
     while this_ob<>nil do
     begin
          this_ob^.transform_to_screen;
          this_ob:=this_ob^.next;
     end;
end;

procedure Apply_Timed_Transforms;
var temp, temp2 : timed_xform_ptr;
    t_now : real;
begin
     t_now:=graphics_time^;

     temp:=first_timed_Xform;
     while temp<>nil do
           if temp^.t_end<t_now then
           begin
                temp2:=temp;
                temp:=temp^.next;
                graphics_time^:=temp2^.t_end;
                temp2^.Update;
                graphics_time^:=t_now;
                if temp2=nil then
                begin
                     stop_graphics;
                     writeln('Temp2 = nil');
                     halt;
                end;
                dispose(temp2,Done);
           end
           else
               temp:=temp^.next;

     temp:=first_timed_Xform;
     while temp<>nil do
     begin
           if temp^.t_start<=t_now then
           begin
                temp^.Update;
              {  temp^.t_last:=t_now;  }{Removed to allow for error correction}
           end;
           temp:=temp^.next;
     end;
end;


{------------------------------------------------}
{ Position and Direction procedures              }
{------------------------------------------------}

procedure Store_Settings;
begin
     setviewpoint:=viewpoint;
     setcolatitude:=colatitude;
     setazimuth:=azimuth;
     setspeed:=speed;
end;

function KeyBoard_Check : boolean;
var correctkey : boolean;
    ch : char;
    ca,sa,cc,sc : longint;
    s : string[4];
begin
     if not(keypressed) then
     begin
          KeyBoard_Check:=false;
          exit;
     end;
     ch:=ReadKey;
     correctkey:=true;
     case ch of
          '2' : colatitude:=colatitude-5;
          '8' : colatitude:=colatitude+5;
          '6' : azimuth:=azimuth-5;
          '4' : azimuth:=azimuth+5;
          '+' : begin
                     CosSin(round(-colatitude*10),cc,sc);
                     CosSin(round(azimuth*10),ca,sa);
                     viewpoint.x:=viewpoint.x-(FixedMul(speed,FixedMul(cc,ca)));
                     viewpoint.y:=viewpoint.y-(FixedMul(speed,FixedMul(cc,sa)));
                     viewpoint.z:=viewpoint.z-(FixedMul(speed,sc));
                     x_pos:=viewpoint.x/65536;
                     y_pos:=viewpoint.y/65536;
                     z_pos:=viewpoint.z/65536;
                end;
          '-' : begin
                     CosSin(round(-colatitude*10),cc,sc);
                     CosSin(round(azimuth*10),ca,sa);
                     viewpoint.x:=viewpoint.x+(FixedMul(speed,FixedMul(cc,ca)));
                     viewpoint.y:=viewpoint.y+(FixedMul(speed,FixedMul(cc,sa)));
                     viewpoint.z:=viewpoint.z+(FixedMul(speed,sc));
                     x_pos:=viewpoint.x/65536;
                     y_pos:=viewpoint.y/65536;
                     z_pos:=viewpoint.z/65536;
                end;
          '*' : speed:=speed shl 2;
          '/' : speed:=speed shr 2;
          's' : begin
                     azimuth:=setazimuth;
                     colatitude:=setcolatitude;
                     speed:=setspeed;
                     viewpoint:=setviewpoint;
                end;
          'q' : begin
                     Stop_Graphics;
                     writeln('Program terminated normally by user');
                     Halt;
                end;
          'p' : begin
                     Str(picture_num,s);
                     Send_Screen_to_PCX('pic'+s+'.pcx');
                     inc(picture_num);
                end;
          'f' : flip_cursor2D_mode;
     else
         correctkey:=this_keyproc(ch);
     end;
     if correctkey then
     begin
          Set_World_to_View(viewpoint.x,viewpoint.y,viewpoint.z,azimuth,colatitude,0);
          main_matrix:=w2v;
     end;
     KeyBoard_Check:=correctkey;
end;

function Mouse_Available : boolean;
begin
     if InitMouse=0 then Mouse_Available:=false else Mouse_Available:=true;
end;


function mouse_check : boolean;
var junk, jx, jy, mouse_x, mouse_y : integer;
    ca,sa,cc,sc, temp_speed : longint;
    change : boolean;
begin
     if cursor2D_mode then mouse_check:=cursor2D_check
     else
     begin
          change:=false;
          ReadMouseCounter(mouse_x, mouse_y);
          if (mouse_x<>0) or (mouse_y<>0) then
          begin
               if mousepress(0,junk,jx,jy)<>3 then
               begin
                    change:=true;
                    azimuth:=azimuth-0.1*mouse_x;
                    colatitude:=colatitude-0.1*mouse_y;
               end
               else
               begin
                    if (mouse_x<>0) then
                    begin
                         temp_speed:=(mouse_x*speed) div 100;
                         change:=true;
                         CosSin(round(azimuth*10),ca,sa);
                         viewpoint.x:=viewpoint.x-(FixedMul(temp_speed,sa));
                         viewpoint.y:=viewpoint.y+(FixedMul(temp_speed,ca));
                         x_pos:=viewpoint.x/65536;
                         y_pos:=viewpoint.y/65536;
                         z_pos:=viewpoint.z/65536;
                    end;
                    if (mouse_y<>0) then
                    begin
                         temp_speed:=(mouse_y*speed) div 100;
                         change:=true;
                         CosSin(round(-(colatitude+90)*10),cc,sc);
                         CosSin(round(azimuth*10),ca,sa);
                         viewpoint.x:=viewpoint.x+(FixedMul(temp_speed,FixedMul(cc,ca)));
                         viewpoint.y:=viewpoint.y+(FixedMul(temp_speed,FixedMul(cc,sa)));
                         viewpoint.z:=viewpoint.z+(FixedMul(temp_speed,sc));
                         x_pos:=viewpoint.x/65536;
                         y_pos:=viewpoint.y/65536;
                         z_pos:=viewpoint.z/65536;
                    end;
               end;
          end;
          if mousepress(0,junk,mouse_x,mouse_y)=1 then
          begin
               change:=true;
               CosSin(round(-colatitude*10),cc,sc);
               CosSin(round(azimuth*10),ca,sa);
               viewpoint.x:=viewpoint.x-(FixedMul(speed,FixedMul(cc,ca)));
               viewpoint.y:=viewpoint.y-(FixedMul(speed,FixedMul(cc,sa)));
               viewpoint.z:=viewpoint.z-(FixedMul(speed,sc));
               x_pos:=viewpoint.x/65536;
               y_pos:=viewpoint.y/65536;
               z_pos:=viewpoint.z/65536;
          end
          else
          if mousepress(0,junk,mouse_x,mouse_y)=2 then
          begin
               change:=true;
               CosSin(round(-colatitude*10),cc,sc);
               CosSin(round(azimuth*10),ca,sa);
               viewpoint.x:=viewpoint.x+(FixedMul(speed,FixedMul(cc,ca)));
               viewpoint.y:=viewpoint.y+(FixedMul(speed,FixedMul(cc,sa)));
               viewpoint.z:=viewpoint.z+(FixedMul(speed,sc));
               x_pos:=viewpoint.x/65536;
               y_pos:=viewpoint.y/65536;
               z_pos:=viewpoint.z/65536;
          end;
          if change then
          begin
               Set_World_to_View(viewpoint.x,viewpoint.y,viewpoint.z,azimuth,colatitude,0);
               main_matrix:=w2v;
          end;
          mouse_check:=change;
     end;
     if mousepress(0,junk,mouse_x,mouse_y)=4 then flip_cursor2D_mode;
end;

procedure flip_cursor2D_mode;
begin
     cursor2D_mode:=not(cursor2D_mode);
     if cursor2D_mode then
     begin
          setmouseposition(cursor_x, cursor_y);
     end;
     delay(200);
end;

function cursor2D_check : boolean;
var junk, mouse_x, mouse_y, xmin, xmax, ymin, ymax : integer;
    last_z, this_z : longint;
    temp_obj, selected_obj : object3d_ptr;
    temp_face : face_ptr;
    temp_str : string;
begin
     ReadMouseCounter(mouse_x, mouse_y);
     junk:=mouseposition(cursor_x, cursor_y);
     if mousepress(0,junk,mouse_x,mouse_y)=1 then
     begin
          mouse_x:=mouse_x div 2;
          mouse_y:=trunc((mouse_y * 1.2)+0.5);
          selected_obj:=nil;
          temp_obj:=first_object;
          last_z:=$7FFFFFFF;
          while temp_obj<>nil do
          begin
                if temp_obj^.shown then temp_obj^.Screen_limits(xmin,xmax,ymin,ymax);
                if temp_obj^.shown and ((xmax>=mouse_x) and (xmin<=mouse_x) and (ymin<=mouse_y) and (ymax>=mouse_y))
                then
                begin
                     this_z:=$7FFFFFFF;
                     temp_face:=temp_obj^.first_face;
                     while temp_face<>nil do
                     begin
                          if Cursor_Inside_Face(temp_face,mouse_x,mouse_y) and temp_face^.seen
                          and (temp_face^.long_sort_z<this_z) then this_z:=temp_face^.long_sort_z;
                          temp_face:=temp_face^.next;
                     end;
                     if (selected_obj=nil) or ((selected_obj<>nil) and (this_z<last_z)) then
                     begin
                          selected_obj:=temp_obj;
                          last_z:=this_z;
                     end;
                end;
                temp_obj:=temp_obj^.next;
          end;
          if selected_obj<>nil then
          begin
               selected_obj^.select_procedure(selected_obj);
               delay(200);
          end;
     end;
end;

function Cursor_Inside_Face(this_face : face_ptr; xpos, ypos : integer) : boolean; external;

procedure User_KeyCheck_Proc(new_keyproc : keyproc);
begin
     this_keyproc:=new_keyproc;
end;


{-----------------------------------------------}
{ Shading procedures                            }
{-----------------------------------------------}

procedure Set_Ambient_Intensity(inten : real);
begin
     if inten<=0 then Ambient_Intensity:=0
     else if inten>=1 then Ambient_Intensity:=65536
     else Ambient_Intensity:=real_to_fixed(inten);
end;

procedure Set_Light(inten, dx, dy, dz : real);
var length : real;
begin
     if inten<=0 then Light_Intensity:=0
     else if inten>=1 then Light_Intensity:=65536
     else Light_Intensity:=real_to_fixed(inten);
     length:=sqrt(sqr(dx)+sqr(dy)+sqr(dz));
     light.x:=real_to_fixed(-dx/length);
     light.y:=real_to_fixed(-dy/length);
     light.z:=real_to_fixed(-dz/length);
end;

procedure Set_Background_Colour(color_in : byte; inten : real);
var temp_c, c : byte;
begin
     if (color_in>=0) and (color_in<=15) and (inten>=0) and (inten<=1) then
        temp_c:=color_in*16+trunc(inten*15+0.5);
     background_colour:=0;
     for c:=1 to 4 do
     begin
          background_colour:=background_colour shl 8;
          background_colour:=background_colour+temp_c;
     end;
end;


{------------------------------------------------}
{ Palette procedures                             }
{------------------------------------------------}

type pal_ptr=^mypalette;
     mypalette=array[0..15,0..15,0..2] of byte;

procedure Set_Palette;
var start : pal_ptr;
    r,g,b : real;
    c,n,col : integer;
    reg : registers;
begin
     new(start);
     col:=0;
     r:=0; g:=0; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=0; g:=63/15; b:=0;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=0; g:=63/15; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=0; b:=0;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=0; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=63/15; b:=0;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=63/15; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=0; g:=63/15; b:=31/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=0; g:=31/15; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=31/15; g:=0; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=0; b:=31/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=31/15; b:=0;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=31/15; g:=63/15; b:=0;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=31/15; g:=31/15; b:=63/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=31/15; g:=63/15; b:=31/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     inc(col);
     r:=63/15; g:=31/15; b:=31/15;
     for c:=0 to 15 do
     begin
          start^[col,c,0]:=round(r*c); start^[col,c,1]:=round(g*c); start^[col,c,2]:=round(b*c);
     end;
     reg.es:=seg(start^);
     reg.dx:=ofs(start^);
     reg.bx:=0;
     reg.cx:=256;
     reg.ax:=$1012;
     Intr($10,reg);
     dispose(start);
end;

type one_color_ptr=^one_color;
     one_color=array[0..15,0..2] of byte;

procedure New_Color(col_no: byte; r, g, b : real);
var my_col : one_color_ptr;
    dr, dg, db : real;
    c : integer;
    reg : registers;
begin
     if (col_no>15) or (col_no<0) then exit;
     if (r>1) or (r<0) or (b>1) or (b<0) or (g>1) or (g<0) then exit;
     new(my_col);
     dr:=63*r/15; dg:=63*g/15; db:=63*b/15;
     col_no:=col_no*16;
     for c:=0 to 15 do
     begin
          my_col^[c,0]:=round(c*dr); my_col^[c,1]:=round(c*dg); my_col^[c,2]:=round(c*db);
     end;
     reg.es:=seg(my_col^);
     reg.dx:=ofs(my_col^);
     reg.bx:=col_no;
     reg.cx:=16;
     reg.ax:=$1012;
     Intr($10,reg);
     dispose(my_col);
end;

procedure Save_Colors(fname : titletype);
var f : text;
    c : integer;
    col : byte;
    reg : registers;
begin
     assign(f,fname);
     rewrite(f);
     for c:=0 to 15 do
     begin
          col:=c*16+15;
          reg.bx:=col;
          reg.ax:=$1015;
          Intr($10,reg);
          writeln(f,reg.dh/63,' ',reg.ch/63,' ',reg.cl/63);
     end;
     close(f);
end;

procedure Load_Colors(fname : titletype);
var f : text;
    r,g,b : real;
    c : integer;
begin
     assign(f,fname);
     reset(f);
     for c:=0 to 15 do
     begin
          readln(f,r,g,b);
          New_Color(c,r,g,b);
     end;
     close(f);
end;

procedure Send_Screen_to_PCX(fname : titletype);
var temp_header : pcx_header;
    pcxf : file;
    reg : registers;
    scan_line : array[0..319] of byte;
    row, plane, multiple, count, value : integer;
begin
     assign(pcxf, fname);
     rewrite(pcxf,1);
     with temp_header do
     begin
          code:=10;
          version:=5;
          mode:=1;
          bits_p_pixel:=8;
          x1:=0;
          x2:=319;
          y1:=0;
          y2:=239;
          Hres:=320;
          Vres:=240;
          junk:=0;
          Nplanes:=1;
          bytes_p_line:=320;
          palette_type:=1;
          for count:=1 to 16 do
          for multiple:=1 to 3 do palette[count,multiple]:=0;
          for multiple:=1 to 58 do padding[multiple]:=0;
          padding[2]:=4;
          padding[4]:=3;
     end;

     BlockWrite(pcxf,temp_header,SizeOf(temp_header));

     for row:=0 to 239 do
     begin
          for plane:=0 to 3 do
          begin
               PortW[$03ce]:=(plane shl 8)+$04;
               for count:=0 to 79 do
                   scan_line[(count*4)+plane]:=Mem[$a000:(screen_page_offset+row*80+count)];
          end;
          multiple:=1;
          value:=scan_line[0];
          count:=1;
          repeat
                while ((count<320) and (scan_line[count]=value)) and (multiple<63) do
                begin
                     inc(count);
                     inc(multiple);
                end;
                if (multiple=1) and ((value and 192)=0) then BlockWrite(pcxf,value,1)
                else
                begin
                     multiple:=multiple or 192;
                     BlockWrite(pcxf,multiple,1);
                     BlockWrite(pcxf,value,1);
                end;
                value:=scan_line[count];
                multiple:=1;
                inc(count);
          until count=321;
     end;

     value:=$0c;
     BlockWrite(pcxf,value,1);
     for count:=0 to 255 do
     begin
          reg.bx:=count;
          reg.ax:=$1015;
          Intr($10,reg);
          value:=reg.dh shl 2;
          BlockWrite(pcxf,value,1);
          value:=reg.ch shl 2;
          BlockWrite(pcxf,value,1);
          value:=reg.cl shl 2;
          BlockWrite(pcxf,value,1);
     end;
     close(pcxf);
end;

procedure Fill_Face(this_face : face_ptr); external;
procedure Fill_Face_Point(this_face : face_ptr); external;
procedure Fill_Face_Line(this_face : face_ptr); external;

procedure ClGSc; external;
procedure Show_Page(page_offset : integer); external;
procedure Stop_Graphics; external;
procedure Start_Graphics; external;
procedure Start_CyberMaxx_Graphics; external;
procedure Sort_Face_List; external;
procedure Clip_Stuff; external;
procedure Text_At(x,y : integer; text : string; colour : byte); external;
procedure Background_At(x,y : integer; text : string; colour : byte); external;

procedure Write_Text_At(x,y : integer; text : string; tcolour : byte; tintensity : real; bcolour : byte; bintensity : real);
begin
     if (x>39) or (y<0) or (y>29) then exit;
     if x<0 then
     begin
          if (length(text)+x)<0 then exit else
          begin
               text:=Copy(text,-x,50);
               x:=0;
          end;
     end;
     if (bcolour>=0) and (bcolour<=15) and (bintensity>=0) and (bintensity<=1) then
        Background_At(x,y,text,bcolour*16+trunc(bintensity*15+0.5));
     if (tcolour>=0) and (tcolour<=15) and (tintensity>=0) and (tintensity<=1) then
        Text_At(x,y,text,tcolour*16+trunc(tintensity*15+0.5));
end;

procedure Set_Text_Proc(temp_textproc : textproc);
begin
     any_textproc:=true;
     this_textproc:=temp_textproc;
end;

procedure Set_Default_Cursor2D;
begin
     cursor_x_offset:=4;
     cursor_y_offset:=4;
{     default_cursor_icon[1]:=11;
     default_cursor_icon[2]:=$FFC0;
     default_cursor_icon[3]:=$FF00;
     default_cursor_icon[4]:=$FE00;
     default_cursor_icon[5]:=$FC00;
     default_cursor_icon[6]:=$FC00;
     default_cursor_icon[7]:=$FE00;
     default_cursor_icon[8]:=$E700;
     default_cursor_icon[9]:=$C380;
     default_cursor_icon[10]:=$81C0;
     default_cursor_icon[11]:=$80E0;
     default_cursor_icon[12]:=$0040;
}    default_cursor_icon[1]:=9;
     default_cursor_icon[2]:=$0800;
     default_cursor_icon[3]:=$0800;
     default_cursor_icon[4]:=$0800;
     default_cursor_icon[5]:=$0800;
     default_cursor_icon[6]:=$F780;
     default_cursor_icon[7]:=$0800;
     default_cursor_icon[8]:=$0800;
     default_cursor_icon[9]:=$0800;
     default_cursor_icon[10]:=$0800;
     cursor_icon:=@default_cursor_icon;
     cursor2d_colour(6,1);
end;

procedure Cursor2D_Colour(number : byte; intens : real);
begin
     if (number>=0) and (number<=15) and (intens>=0) and (intens<=1) then
        Cursor_colour:=number*16+trunc(intens*15+0.5);
end;

procedure Draw_Cursor2D(xpos, ypos : integer); external;

function Now : real;
begin
     Now:=graphics_time^;
end;

function NulKeyProc(key : char) : boolean;
begin
     NulKeyProc:=false;
end;

procedure NulSelectProc(this_object : object3d_ptr);
begin
end;

function Load_Picture(filename : string) : pointer;
var pcxf : file;
    size, tw, th : integer;
    width, height, mybyte, x, y : byte;
    count : integer;
    temp : pointer;
    temp_seg, temp_ofs : word;
    temp_header : pcx_header;
begin
     assign(pcxf,filename);
     reset(pcxf,1);
     BlockRead(pcxf,temp_header,sizeof(pcx_header));
     writeln('PCX Name = ',filename);
     with temp_header do
     begin
          writeln('Code = ',code);
          writeln('Version = ',version);
          writeln('Mode = ',mode);
          writeln('Bits per pixel = ',bits_p_pixel);
          writeln('Screen coordinates = ',x1,',',y1,' to ',x2,',',y2);
          writeln('Screen_Res = ',Hres,',',vres);
          writeln('Planes = ',Nplanes);
          writeln('Bytes p line = ',bytes_p_line);
          writeln('Palette_type = ',palette_type);
          writeln;
     end;
     if (temp_header.version<>5) and (temp_header.bits_p_pixel<>8) then
     begin
          writeln('Error! - ',filename,' is not a 256 colour PCX file');
          Load_Picture:=nil;
          exit;
     end;
     width:=temp_header.bytes_p_line;
     writeln(temp_header.bytes_p_line);
     writeln('Width = ',width);
     height:=temp_header.y2-temp_header.y1+1;
     writeln('Height = ',height);
     if width>255 then
     begin
          writeln('Error! - ',filename,' has a width >255');
          Load_Picture:=nil;
          exit;
     end;
     if height>255 then
     begin
          writeln('Error! - ',filename,' has a height >255');
          Load_Picture:=nil;
          exit;
     end;
     size:=word(width)*word(height)+2;
     writeln('Freeing ',size,' bytes');
     GetMem(temp,size);
     temp_seg:=Seg(temp^);
     temp_ofs:=Ofs(temp^);
     Mem[temp_seg:temp_ofs]:=width;
     Mem[temp_seg:temp_ofs+1]:=height;
     size:=word(width)*word(height);
     temp_ofs:=temp_ofs+2;
     y:=0;
     repeat
           x:=0;
           repeat
                 BlockRead(pcxf,mybyte,1);
                 if (mybyte and 192)=192 then
                 begin
                      count:=(mybyte and 63);
                      BlockRead(pcxf,mybyte,1);
                      while count>0 do
                      begin
                           Mem[temp_seg:temp_ofs]:=mybyte;
                           inc(temp_ofs);
                           dec(count);
                           inc(x);
                      end;
                 end
                 else
                 begin
                      Mem[temp_seg:temp_ofs]:=mybyte;
                      inc(temp_ofs);
                      inc(x);
                 end;
           until x>=(temp_header.bytes_p_line);
           temp_ofs:=temp_ofs-(x-width);
           inc(y);
     until y=height;
     Load_Picture:=temp;
end;


function Number_of_Objects : integer;
var total : integer;
    temp_object : object3d_ptr;
begin
     total:=0;
     temp_object:=first_object;
     while temp_object<>nil do
     begin
          inc(total);
          temp_object:=temp_object^.next;
     end;
     Number_of_Objects:=total;
end;

function Number_of_Faces : integer;
var total : integer;
    temp_object : object3d_ptr;
    temp_face : face_ptr;
begin
     total:=0;
     temp_object:=first_object;
     while temp_object<>nil do
     begin
          temp_face:=temp_object^.first_face;
          while temp_face<>nil do
          begin
               inc(total);
               temp_face:=temp_face^.next;
          end;
          temp_object:=temp_object^.next;
     end;
     Number_of_Faces:=total;
end;


function Number_of_Vertices : integer;
var total : integer;
    temp_object : object3d_ptr;
    temp_vertex : vertex_ptr;
begin
     total:=0;
     temp_object:=first_object;
     while temp_object<>nil do
     begin
          temp_vertex:=temp_object^.first_vertex;
          while temp_vertex<>nil do
          begin
               inc(total);
               temp_vertex:=temp_vertex^.next;
          end;
          temp_object:=temp_object^.next;
     end;
     Number_of_Vertices:=total;
end;