rem Box Solid ..... Rev 3.2
      rem A J Tooth / 14th November 2003
      rem Improved 6th March 2004 using BB4W 3.00c enhancements
      rem Revised 30th December 2006
      rem +++++++++++++++++++++++++++++++++++++++++++++++++++++
      on error if (err=17) then quit
      
      rem =====================================================
      rem Illustrates Rotation of Axes using EULER ANGLES.
      rem Also utilises TRUE Perspective.
      rem =====================================================
      
      rem Setup
      proc_setup
      
      rem Place Origin and Draw Axes
      proc_place
      
      rem Rotation Section
      repeat
        rem Increment Parameters - with Truncation Control
        proc_incr
        
        rem Main Subroutine
        proc_mainsub(theta,phi,psi,vht,hdis,sw&)
        
        rem Adjust parameters
        proc_adjust(sp$,sw&)
        
      until (sp$="s" or sp$="r")
      if sp$="r" then run
      quit
      end
      rem End of Programme ---------------------------------------
      
      rem Initial Axis Vectors
      data 1,-1,-1,1,1,-1,-1,1,-1,-1,-1,-1
      data 1,-1,1,1,1,1,-1,1,1,-1,-1,1
      
      data 1,2,3,4,1,5,6,2,1,5,2,6,7,3,2,3,7,8,4,3,4,8,5,1,4,5,6,7,8,5
      data 0,0,1,1,1,0,0,1,1,1,0,0,1,1,1,0,0,1,1,1,0,0,1,1,1,0,0,1,1,1
      rem---------------------------------------------------------
      
      rem Setup
      def proc_setup
      
      *FLOAT 64
      rem Call Utility Procedures
      proc_fullscreen(xscreen%,yscreen%) : rem Set up use of Full Screen
      
      rem Set up Initial Axis Arrays
      rem Dimension Axes Array and Projection Array
      
      dim boxor(8,3),boxnow(8,3),bxalpbet(8,2),boxpos(8,2)
      dim verseq&(30,2)
      dim Th% 7, Ph% 7, Ps% 7
      dim Mat% 71
      dim mat% 1000
      
      rem Dual-pass assembly, in case of labels
      for pass&=0 to 2 step 2
        proc_mat(pass&)
      next pass&
      
      rem Display my Icon in compiled version
      proc_AJTicon(10,700)
      endproc
      rem---------------------------------------------------------
      
      rem Place Origin and Draw Axes
      def proc_place
      
      print : print " Choosing a SMALL cube will EXAGGERATE the PERSPECTIVE !"
      print : input " Choose a small cube or large one ( -s- or -l-)(l)",cub$
      
      if (cub$="" or cub$="l") then cub$="l" else cub$="s"
      case cub$ of
        when "s" : vht=3 : hdis=3 : SCL%=750
        when "l" : vht=350 : hdis=350 : SCL%=1250
      endcase
      
      cls
      rem Initialise angles
      theta=0 : phi=0 : psi=0
      dth=0 : dph=0 : dps=0 : dh=0 : dv=0
      
      if cub$="l" then Fac%=10 else Fac%=1
      
      rem Loads Initial Axes Vertex Vectors
      restore
      for aa&=1 to 8
        for bb&=1 to 3
          read nx% : boxor(aa&,bb&)=Fac%*nx%
        next bb&
      next aa&
      rem Loads Vertex Printing Sequence
      for m&=1 to 2
        for c&=1 to 30
          read verseq&(c&,m&)
        next c&
      next m&
      
      rem Centres Graphics and sets scale
      R=fn_R(vht,hdis)
      xmax%=xscreen% : zmax%=yscreen%
      scl%=int(SCL%*R)
      origin xmax%,zmax% : gcol 3
      sw&=1
      endproc
      rem---------------------------------------------------------
      
      rem Master Subroutine
      def proc_mainsub(Theta,Phi,Psi,vh,hd,sw&)
      local d%
      
      proc_rotmat(Theta,Phi,Psi)
      proc_boxrot
      
      for d&=1 to 8
        proc_bxalpha(vh,hd,d&)
        proc_bxbeta(vh,hd,d&)
      next d&
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &100
      proc_boxdraw(vh,hd,sw&)
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &20
      rem Display my Icon in compiled version
      proc_AJTicon(10,700)
      
      endproc
      rem---------------------------------------------------------
      
      rem Adjust parameters
      def proc_adjust(return Sp$,return Sw&)
      local sp&
      
      Sp$=inkey$(0)
      if Sp$="t" then Sw&=1-Sw&
      sp&=asc(Sp$)
      case sp& of
        when 44  : dps-=.1 : if abs(dps)<.1 then dps=0
        when 46  : dps+=.1 : if abs(dps)<.1 then dps=0
        when 98  : dh+=.01 : if abs(dh)<.01 then dh=0
        when 102 : dh-=.01 : if abs(dh)<.01 then dh=0
        when 100 : dv-=.01 : if abs(dv)<.01 then dv=0
        when 117 : dv+=.01 : if abs(dv)<.01 then dv=0
        when 136 : dth-=.1 : if abs(dth)<.1 then dth=0
        when 137 : dth+=.1 : if abs(dth)<.1 then dth=0
        when 138 : dph-=.1 : if abs(dph)<.1 then dph=0
        when 139 : dph+=.1 : if abs(dph)<.1 then dph=0
        when 32  : dv=0 : dh=0
        otherwise
      endcase
      endproc
      rem---------------------------------------------------------
      
      rem Increment Parameters - with Truncation Control
      def proc_incr
      
      theta+=dth : phi+=dph : psi+=dps
      if theta>360 then theta=theta-360
      if theta<-360 then theta=theta+360
      if phi>360 then phi=phi-360
      if phi<-360 then phi=phi+360
      if psi>360 then psi=psi-360
      if psi<-360 then psi=psi+360
      
      vht+=dv : hdis+=dh : if hdis<1 then hdis=1 : dh=0
      vht=fn_Int(vht,100) : hdis=fn_Int(hdis,100)
      theta=fn_Int(theta,10) : phi=fn_Int(phi,10) : psi=fn_Int(psi,10)
      endproc
      rem---------------------------------------------------------
      
      rem Rotation Matrix Update
      def proc_rotmat(Thet,Phii,Psii)
      
      |Th%=0.00001+rad(Thet) : |Ph%=0.00001+rad(Phii) : |Ps%=0.00001+rad(Psii)
      
      call mat%
      
      endproc
      
      rem---------------------------------------------------
      
      rem Rotate Box
      def proc_boxrot
      local i&,j&,k&,cum
      
      for i&=1 to 8
        for j&=1 to 3
          cum=0
          for k&=1 to 3
            ost%=(j&-1)*24 + (k&-1)*8
            cum=cum + (|(Mat%+ost%))*boxor(i&,k&)
          next k&
          boxnow(i&,j&)=cum
        next j&
      next i&
      
      endproc
      rem--------------------------------------------------
      
      rem Set up use of Full Screen
      def proc_fullscreen(return xscreen%,return yscreen%)
      
      sys "GetSystemMetrics", 0 to xscreen%
      sys "GetSystemMetrics", 1 to yscreen%
      sys "SetWindowLong",@hwnd%,-16,&16000000
      sys "SetWindowPos",@hwnd%,-1,0,0,xscreen%,yscreen%,0
      vdu 23,22,xscreen%;yscreen%;8,16,16,1 : rem Set fullscreen mode
      mouse off : off : rem Turns off the Mouse Pointer and the Cursor
      endproc
      
      rem--------------------------------------------------
      rem +++++++++++++++++++++++++++++++++++++++++++++++++
      rem--------------------------------------------------
      
      rem Calculates line of sight distance for 2-D View Angle
      def fn_bxrdis(Vht,Hdis,Vr%)
      local xd,yd,zd
      
      xd=boxnow(Vr%,1) : yd=boxnow(Vr%,2)+Hdis : zd=boxnow(Vr%,3)-Vht
      =sqr(xd*xd+yd*yd+zd*zd)
      
      rem Calculates normalising factor for normal to position vector plane
      def fn_bxnpl(Vht,Hdis,Vr%)
      local xd,yd,zd
      xd=Hdis*boxnow(Vr%,1) : yd=Vht*boxnow(Vr%,1) : zd=Vht*boxnow(Vr%,2)+Hdis*boxnow(Vr%,3)
      =sqr(xd*xd+yd*yd+zd*zd)
      
      rem Calculates distance from Origin to Vertex
      def fn_rmod(Vr%)
      local xd,yd,zd
      xd=boxnow(Vr%,1) : yd=boxnow(Vr%,2) : zd=boxnow(Vr%,3)
      =sqr(xd*xd+yd*yd+zd*zd)
      
      rem Calculates Distance to Origin
      def fn_R(Vh,Hd)
      =sqr(Vh*Vh+Hd*Hd)
      rem--------------------------------------------------
      
      rem Angle between vertical plane and plane containing position vector
      def proc_bxalpha(Vht,Hdis,Ver%)
      local npl,num
      npl=fn_bxnpl(Vht,Hdis,Ver%)
      num=Vht*boxnow(Ver%,2)+Hdis*boxnow(Ver%,3)
      if npl=0 then bxalpbet(Ver%,1)=pi/2 else bxalpbet(Ver%,1)=acs(num/npl)
      if boxnow(Ver%,1)>0 then bxalpbet(Ver%,1)=2*pi-bxalpbet(Ver%,1)
      endproc
      
      rem 2-D Projection View-Angle
      def proc_bxbeta(Vht,Hdis,Ver%)
      local rdis,yfact,zfact
      rdis=fn_bxrdis(Vht,Hdis,Ver%)
      rmod=fn_rmod(Ver%) : R=fn_R(Vht,Hdis)
      yfact=Hdis*(Hdis+boxnow(Ver%,2)) : zfact=Vht*(Vht-boxnow(Ver%,3))
      bxalpbet(Ver%,2)=acs((yfact+zfact)/(rdis*R))
      
      rem Convert from Polar to x/y Coords for Printing to Screen
      boxpos(Ver%,1)=(rmod/rdis)*bxalpbet(Ver%,2)*(-sin(bxalpbet(Ver%,1)))
      boxpos(Ver%,2)=(rmod/rdis)*bxalpbet(Ver%,2)*cos(bxalpbet(Ver%,1))
      endproc
      rem--------------------------------------------------
      
      rem Draw Box on Screen
      def proc_boxdraw(Vh,Hd,Swt&)
      local k%,l%,a$,Ind%,Jnd%
      
      *REFRESH OFF
      for k&=1 to 30
        
        col&=1-(k&>5)-(k&>10)-(k&>15)-(k&>20)-(k&>25)
        Ind&=verseq&(k&,1)
        if verseq&(k&,2)=0 then
          move scl%*boxpos(Ind&,1),scl%*boxpos(Ind&,2)
        else
          Indpre&=verseq&((k&-2),1)
          mx=(boxnow(Ind&,1)+boxnow(Indpre&,1))/2
          my=(boxnow(Ind&,2)+boxnow(Indpre&,2))/2
          mz=(boxnow(Ind&,3)+boxnow(Indpre&,3))/2
          Tes=-Hd*my + Vh*mz - (mx*mx+my*my+mz*mz)
          if Tes>0.7 then
            gcol col&
            plot 85,scl%*boxpos(Ind&,1),scl%*boxpos(Ind&,2)
          endif
        endif
      next k&
      
      if Swt&=1 then
        Lst&=Swt&
        print tab(5,1);"THETA =";theta;"        "
        print tab(5,2);"PHI = ";phi;"         "
        print tab(5,3);"PSI =";psi;"           "
        
        print tab(5,5);"Delta Theta = ";dth;"            "
        print tab(5,6);"Delta Phi = ";dph;"          "
        print tab(5,7);"Delta Psi = ";dps;"           "
        print tab(5,9);"Height = ";Vh;"              "
        print tab(5,10);"Distance = ";Hd;"           "
      else
        if Lst&=1 then cls : Lst&=0
      endif
      *REFRESH
      
      for l&=1 to 30
        
        Jnd&=verseq&(l&,1)
        if verseq&(l&,2)=0 then
          move scl%*boxpos(Jnd&,1),scl%*boxpos(Jnd&,2)
        else
          gcol 0
          plot 85,scl%*boxpos(Jnd&,1),scl%*boxpos(Jnd&,2)
        endif
      next l&
      
      endproc
      rem--------------------------------------------------
      
      rem Truncation Function
      def fn_Int(Num,Acc%)
      =(int((Num+.001)*(Acc%)))/Acc%
      
      rem--------------------------------------------------
      
      rem Assembly Language Routine 1
      rem for Rotation Matrix calculation
      def proc_mat(opt&)
      P%=mat%
      [opt opt&
      
      finit
      fld qword [Th%]          ;Mat(1,1)
      fsin
      fld qword [Ps%]
      fsin
      fmulp st1,st0
      fld qword [Th%]
      fcos
      fld qword [Ph%]
      fcos
      fld qword [Ps%]
      fcos
      fmulp st1,st0
      fmulp st1,st0
      fsubrp st1,st0
      fstp qword [Mat%]
      
      fld qword [Th%]          ;Mat(1,2)
      fsin
      fld qword [Ps%]
      fcos
      fmulp st1,st0
      fld qword [Th%]
      fcos
      fld qword [Ph%]
      fcos
      fld qword [Ps%]
      fsin
      fmulp st1,st0
      fmulp st1,st0
      fchs
      fsubrp st1,st0
      fstp qword [(Mat%+8)]
      
      fld qword [Th%]          ;Mat(1,3)
      fcos
      fld qword [Ph%]
      fsin
      fmulp st1,st0
      fchs
      fstp qword [(Mat%+16)]
      
      fld qword [Th%]          ;Mat(2,1)
      fcos
      fld qword [Ps%]
      fsin
      fmulp st1,st0
      fld qword [Th%]
      fsin
      fld qword [Ph%]
      fcos
      fld qword [Ps%]
      fcos
      fmulp st1,st0
      fmulp st1,st0
      faddp st1,st0
      fstp qword [(Mat%+24)]
      
      fld qword [Th%]          ;Mat(2,2)
      fcos
      fld qword [Ps%]
      fcos
      fmulp st1,st0
      fld qword [Th%]
      fsin
      fld qword [Ph%]
      fcos
      fld qword [Ps%]
      fsin
      fmulp st1,st0
      fmulp st1,st0
      fsubp st1,st0
      fstp qword [(Mat%+32)]
      
      fld qword [Th%]          ;Mat(2,3)
      fsin
      fld qword [Ph%]
      fsin
      fmulp st1,st0
      fchs
      fstp qword [(Mat%+40)]
      
      fld qword [Ph%]          ;Mat(3,1)
      fsin
      fld qword [Ps%]
      fcos
      fmulp st1,st0
      fstp qword [(Mat%+48)]
      
      fld qword [Ph%]          ;Mat(3,2)
      fsin
      fld qword [Ps%]
      fsin
      fmulp st1,st0
      fchs
      fstp qword [(Mat%+56)]
      
      fld qword [Ph%]          ;Mat(3,3)
      fcos
      fstp qword [(Mat%+64)]
      
      ret
      ]
      endproc
      rem ===============================================================
      
      rem Displays my Icon in .exe version
      def proc_AJTicon(i%,j%)
      sys "GetModuleHandle", 0 to hm%
      sys "LoadImage", hm%, "BBCWin", 1, 32, 32, 0 to hicon%
      w% = 32
      h% = 32
      sys "DrawIconEx", @memhdc%, i%, j%, hicon%, w%, h%, 0, 0, 3
      sys "InvalidateRect", @hwnd%, 0, 0
      endproc
      rem ===============================================================