'
'3D Terain Creator 
'Richard Wheeldon 1996 
'
Set Buffer 400
Set Stack 3000
Reserve As Chip Data 10,65535
Set Tempras Start(10),65535
'
'Planet Constants
Global DIST,ZOM,XMID,YMID,YFACT
Global XF,YF,ZF
DIST=500 : ZOM=30
XMID=0 : YMID=20
XF=50 : YF=50 : ZF=15
YFACT=20
'
Global RIVERS,LSIZE,THRESH,RIVMARK
RIVERS=80
LSIZE=80
THRESH=10
RIVMARK=160
'
XSIZE=40 : YSIZE=40
Dim MAP(XSIZE,YSIZE)
Global XSIZE,YSIZE,MAP()
Print "Please Wait. Setting up Islands."
GENMAP
Screen Open 0,320,200,32,Lowres
Curs Off : Flash Off : Paper 0 : Cls 
'Palette $9,$9,$9,$50,$50,$50,$50,$50,$50,$A80,$A80,$A80,$444,$666,$888,$FFF 
Palette $0,$999,$AAA,$BBB,$CCC,$DDD,$EEE,$FFF,$F
Colour 16,$F
MAIN
'
Procedure MAIN
   Do 
      _SHOWLAND
      Repeat 
         I$=Inkey$
         S=Scancode
      Until I$<>""
      If I$="6"
         Add XMID,20
      Else If I$="4"
         Add XMID,-20
      Else If I$="8"
         Add YMID,-20
      Else If I$="2"
         Add YMID,20
      Else If I$="7"
         Add DIST,-20
      Else If I$="9"
         Add DIST,20
      Else If I$="1"
         Add ZOM,-20
      Else If I$="3"
         Add ZOM,20
      Else If I$="5"
         ROTMAP
      Else If I$=Chr$(27)
         Edit 
      End If 
   Loop 
End Proc
'
Procedure SHWMAP
   For X=0 To XSIZE
      For Y=0 To YSIZE
         Ink MAP(X,Y)/THRESH
         Bar X*5,Y*4 To X*5+4,Y*4+3
      Next 
   Next 
End Proc
Procedure GENMAP
   For C=0 To 30+Rnd(30)
      GENISLAND[Rnd(XSIZE),Rnd(YSIZE),Rnd(LSIZE)]
   Next 
   For X=0 To XSIZE
      For Y=0 To YSIZE
         MAP(X,Y)=MAP(X,Y)/YFACT
      Next 
   Next 
   '_ADD_MOUNTAINS
   '_ADD_RIVERS 
End Proc
Procedure GENISLAND[X,Y,R]
   If X<0 Then Pop Proc
   If X>XSIZE Then Pop Proc
   If Y<0 Then Pop Proc
   If Y>YSIZE Then Pop Proc
   Add MAP(X,Y),R
   MAP(X,Y)=Min(MAP(X,Y),THRESH*15)
   If R>0
      D=Rnd(3)
      If D=0
         GENISLAND[X,Y+1,R-1]
      Else If D=1
         GENISLAND[X+1,Y,R-1]
      Else If D=2
         GENISLAND[X,Y-1,R-1]
      Else 
         GENISLAND[X-1,Y,R-1]
      End If 
   End If 
End Proc
Procedure _ADD_RIVERS
   For C1=0 To RIVERS
      X=Rnd(XSIZE)
      Y=Rnd(YSIZE)
      While MAP(X,Y)>30 and MAP(X,Y)<>RIVMARK
         M=MAP(X,Y)
         MAP(X,Y)=RIVMARK
         '
         Trap M1=MAP(X,Y+1) : If Errtrap Then M1=5000
         Trap M2=MAP(X,Y-1) : If Errtrap Then M2=5000
         Trap M3=MAP(X+1,Y) : If Errtrap Then M3=5000
         Trap M4=MAP(X-1,Y) : If Errtrap Then M4=5000
         '
         If M<M1 and M<M2 and M<M3 and M<M4
            MAP(X,Y)=30
         Else If M1<=M2 and M1<=M3 and M1<=M4
            Inc Y
         Else If M2<=M1 and M2<=M3 and M2<=M4
            Dec Y
         Else If M3<=M2 and M3<=M1 and M3<=M4
            Inc X
         Else If M4<=M2 and M4<=M3 and M4<=M1
            Dec X
         End If 
      Wend 
   Next 
End Proc
Procedure _SHOWLAND
   Cls 
   For Y=YSIZE-1 To 0 Step -1
      For X=0 To XSIZE-1
         If MAP(X,Y)=0 and MAP(X+1,Y)=0 and MAP(X,Y+1)=0 and MAP(X+1,Y+1)=0
            Ink 8
         Else 
            CALCCOL[X*XF,-YF*MAP(X,Y),700+Y*ZF,XF*(X+1),-YF*MAP(X+1,Y),Y*ZF+700,XF*(X+1),-YF*MAP(X+1,Y+1),(Y+1)*ZF+700,XF*X,-YF*MAP(X,Y+1),(Y+1)*ZF+700]
            Ink Param
         End If 
         _BAR3D[X*XF,-YF*MAP(X,Y),700+Y*ZF,XF*(X+1),-YF*MAP(X+1,Y),Y*ZF+700,XF*(X+1),-YF*MAP(X+1,Y+1),(Y+1)*ZF+700,XF*X,-YF*MAP(X,Y+1),(Y+1)*ZF+700]
      Next 
   Next 
   '   Y=YSIZE
   '   For X=0 To XSIZE-1 
   '      Ink Rnd(6)+1
   '      _BAR3D[X*F,-F*MAP(X,Y),700+Y*F,F*(X+1),-F*MAP(X+1,Y),Y*F+700,F*(X+1),0,Y*F+700,X*F,0,700+Y*F] 
   '   Next 
   '   X=XSIZE
   '   For Y=0 To YSIZE-1 
   '      Ink Rnd(6)+1
   '      _BAR3D[X*F,-F*MAP(X,Y),700+Y*F,F*X,-F*MAP(X,Y+1),(Y+1)*F+700,X*F,0,700+(Y+1)*F,F*X,0,Y*F+700] 
   '   Next 
End Proc
Procedure _LINE3D[X1,Y1,Z1,X2,Y2,Z2]
   XP1=XMID+(X1*ZOM)/(DIST+Z1)
   YP1=YMID+(Y1*ZOM)/(DIST+Z1)
   XP2=XMID+(X2*ZOM)/(DIST+Z2)
   YP2=YMID+(Y2*ZOM)/(DIST+Z2)
   Draw XP1,YP1 To XP2,YP2
End Proc
Procedure _BAR3D[X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4]
   Y1=-Y1-1000 : Y2=-Y2-1000
   Y3=-Y3-1000 : Y4=-Y4-1000
   '
   X1=-X1-1000 : X2=-X2-1000
   X3=-X3-1000 : X4=-X4-1000
   '  
   Z1=-Z1 : Z2=-Z2
   Z3=-Z3 : Z4=-Z4
   '
   XP1=XMID+(X1*ZOM)/(DIST+Z1)
   YP1=YMID+(Y1*ZOM)/(DIST+Z1)
   '
   XP2=XMID+(X2*ZOM)/(DIST+Z2)
   YP2=YMID+(Y2*ZOM)/(DIST+Z2)
   '
   XP3=XMID+(X3*ZOM)/(DIST+Z3)
   YP3=YMID+(Y3*ZOM)/(DIST+Z3)
   '
   XP4=XMID+(X4*ZOM)/(DIST+Z4)
   YP4=YMID+(Y4*ZOM)/(DIST+Z4)
   '
   Polygon XP1,YP1 To XP2,YP2 To XP3,YP3 To XP4,YP4
   '   Print At(0,0);XP4;" ";YP4;" "
End Proc
Procedure ROTMAP
   Dim MAP2(XSIZE,XSIZE)
   For X1=0 To XSIZE
      For Y1=0 To XSIZE
         MAP2(X1,Y1)=MAP(Y1,XSIZE-X1)
      Next 
   Next 
   For X1=0 To XSIZE
      For Y1=0 To XSIZE
         MAP(X1,Y1)=MAP2(X1,Y1)
      Next 
   Next 
End Proc
'
Procedure CALCCOL[X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4]
   On Error Goto E
   LX#=0
   LY#=500
   LZ#=0
   '
   G1#=1.0*(Y1+Y2-Y3-Y4)/((Z3-Z1)*2)
   G2#=1.0*(Y2+Y3-Y4-Y1)/((X2-X1)*2)
   '
   IG1#=-1.0/G1#
   IG2#=-1.0/G2#
   '
   CX#=(X1+X2)/2.0
   CY#=(Y1+Y2+Y3+Y4)/4.0
   CZ#=(Z1+Z3)/2.0
   '
   K1#=CY#-(IG1#*CZ#)
   K2#=CY#-(IG1#*CX#)
   '
   VX#=(LY#-K2#)/IG2#
   VY#=LY#
   VZ#=(LY#-K1#)/IG1#
   '
   A2#=(LX#-VX#)^2+(LY#-VY#)^2+(LY#-VY#)^2
   B2#=(LX#-CX#)^2+(LY#-CY#)^2+(LY#-CY#)^2
   C2#=(CX#-VX#)^2+(CY#-VY#)^2+(CY#-VY#)^2
   '
   B#=Sqr(B2#) : C#=Sqr(C2#)
   '
   C#=-(A2#-B2#-C2#)/(2.0*B#*C#)
   '
   C=1+Int(6*C#)
   '
   Pop Proc[C]
   '
   E:
   Resume Next 
End Proc