aUCBLogo Demos and Tests / landscape4sh

to landscape4sh [randomvalue -1]
   ; 70033224, 459159795 or 148549210, 1617112103 are nice
   randomvalue=70033224
;   fullScreen
;   allFullScreen
   perspective
   setUpdateGraph false
   setLightAmbient RGB .3 .3 .3
   r_0=2^6      ;increase if you want to fly farer
   maxy=200
   sealevel=0
   rfactor=40
   yfactor=5
   minside=1
   miny=2
   hsize=30
   ifelse randomvalue==-1
   [   seedvalue=random IntMax
      (reRandom seedvalue)
      pr seedvalue
   ][   (reRandom randomvalue)
   ]
   p=quad r_0

   mypal=loadpalette "topograf.pal
   hideTurtle
   setScreenColor 1
   cs   ;to delete all textures
;   clearShadows
;   enableShadows

   grass=loadImage "grass.jpg
   texGrass=Texture grass
   makeSemiTransparent grass
   texGrassAlpha=Texture grass

   rock=loadImage "rockbricks.jpg
   texRock=Texture rock
   makeSemiTransparent rock
   texRockAlpha=Texture rock

   bricks=loadImage "bricks.png
   texBricks=Texture bricks
   rooftiles=loadImage "rooftiles.png
   texRooftiles=Texture rooftiles

   r=r_0
   landscapegraphic=Graphic
   [   PenUp
      setX -r
      setZ -r
      PenDown
      Texture texGrass
      dx=0
      dz=0
      Surface
      [   for [z -r r minside]
         [   py=p.(Int z)
            for [x -r r minside]
            [   setPenColor mypal.(Int 1+255*(0.5+py.x/maxy))
               if py.x < sealevel [py.x=sealevel]
               dx=0.3*sin 2*360*(x+z)/r
               dz=0.3*sin 3*360*(x-z)/r
               setTexXY x/minside/2+dx z/minside/2+dz
               setXYZ rfactor*x yfactor*py.x rfactor*z
            ]
            SurfaceColumn
         ]
      ]
;comment[
      setPenColor HSBA 0 0 1 0.5
      Texture texGrassAlpha
      for [plane 0.2 1 0.05]
      [   dx=0
         dz=0
         Surface
         [   for [z -r r minside]
            [   py=p.(Int z)
               for [x -r r minside]
               [   if py.x < sealevel [py.x=sealevel]
                  dx=0.3*sin 2*360*(x+z)/r
                  dz=0.3*sin 3*360*(x-z)/r
                  setTexXY x/minside/2+dx z/minside/2+dz
                  setXYZ rfactor*x yfactor*py.x+plane/3 rfactor*z
                  dx=dx+0.1
               ]
               SurfaceColumn
            ]
         ]
      ]
;]
comment [
      peak=(max p)
      for [z -r r minside]
      [   py=p.(Int z)
         for [x -r r minside]
         [   if py.x==peak
            [   (drawcross rfactor*x yfactor*peak rfactor*z 4)
               x=r
               z=r
            ]
         ]
      ]
]
      repeat 50
      [   x=(rnd-0.5)*2*r  x=int x-modulo x minside
         z=(rnd-0.5)*2*r  z=int z-modulo z minside
         drawhouse x z
      ]
      Texture texRockAlpha
      repeat 100
      [   x=(rnd-0.5)*2*r  x=int x-modulo x minside
         z=(rnd-0.5)*2*r  z=int z-modulo z minside
         drawtree x z
      ]
   ]

   PenUp  home  setXYZ 0 (p.0).0+maxy 0    downPitch 90
   disableShadows
   video=true
;   video=false
   if video [(VideoStart "landscape4sh.divx 25)]
   fly_around
   if video [VideoEnd]
   notFullScreen
   splitScreen
end

be makeSemiTransparent bmp
   local [mx my c r g b a]
   mx=BitMaxX bmp
   my=BitMaxY bmp
   for [x 0 mx 1]
   [   for [y 0 my 1]
      [   c=reRGBA BitPixel bmp x y
         r_=c.1 g=c.2 b=c.3
         a=sqr r_
         if a < 0.2 [a=0]
         BitSetPixel bmp x y RGBA r_ g b a
      ]
   ]
end

to drawhouse x z
   if (p.z).x==sealevel [stop]
   home
   leftroll random 360
   PenUp
   setXYZ rfactor*x yfactor*(p.z).x+hsize/2 rfactor*z
   house_and_cube
end

to house_and_cube
   (house hsize)
   csize=hsize*1.1
   bk hsize
   setPC "white
   Texture texrock
   (tcube csize)
;   disableTexture
end

to drawtree x z
   if (p.z).x==sealevel [stop]
   tsize=40+random 20
   PenUp
   home
   setXYZ rfactor*x yfactor*(p.z).x rfactor*z
   leftRoll rnd*360
   disableRoundLineEnds
   setPC HSBA 30 0.5 0.5 1
   disableTexture
   Cylinder tsize/2 tsize/10*0.9
   enableTexture
   setPC HSBA 30 0.5 0.5 1
;comment[
   for [z 0.9 1 0.03]
   [   Cylinder tsize/2 tsize/10*z
   ]
;]
   fd tsize-3
   disableTexture
   setPC HSBA 120 0.8 0.2 0.8
   Sphere tsize/2*0.5
   enableTexture
   setPC HSBA 120 0.8 0.5 1
;comment[
   for [z 0.5 1 0.02]
   [   Sphere tsize/2*z
   ]
;]
end

to fly_around
   local [eye light center upvector eyepos eyeori]
   center={0 0 0}
   upvector={0 1 0}
   eye=array 3
   light=array 3
   ang=3.6
   v=0+1.0
   dv=0.0
   a=v/300
   vmax=3
      Ï={0 0 0}
   dÏ=0.05
   eyecenter=100
   eyecenter2=eyecenter*2
   shadows=false

   penUp
   eye=Array PosXYZ
   forward eyecenter
   center=Array PosXYZ
   back eyecenter

   print [left, right, up and down rotates, x c rolls, a y changes speed, ESC exits]
   WXK_A=ASCII upperCase "A
   WXK_Y=ASCII upperCase "Y
   WXK_X=ASCII upperCase "X
   WXK_C=ASCII upperCase "C
   WXK_S=ASCII upperCase "S
   maingraph=GraphCurrent
   WindowSetFocus maingraph
   WindowOnKeyDown maingraph
   [   k=KeyboardValue
      case k
      [   [WXK_UP    kup   =true]
         [WXK_DOWN  kdown =true]
         [WXK_RIGHT kright=true]
         [WXK_LEFT  kleft =true]
         [WXK_A     kacc  =true]
         [WXK_Y     kbreak=true]
         [WXK_X     klr   =true]
         [WXK_C     krr   =true]
         [WXK_ESCAPE running=false]
      ]
   ]
   WindowOnKeyUp maingraph
   [   k=KeyboardValue
      case k
      [   [WXK_UP    kup   =false]
         [WXK_DOWN  kdown =false]
         [WXK_RIGHT kright=false]
         [WXK_LEFT  kleft =false]
         [WXK_A     kacc  =false]
         [WXK_Y     kbreak=false]
         [WXK_X     klr   =false]
         [WXK_C     krr   =false]
      ]
   ]
   kup   =false
   kdown =false
   kright=false
   kleft =false
   kacc   =false
   kbreak=false
   klr   =false
   krr   =false

   dispatchMessages
   running=true
   while [running]
   [   setEye eye center upvector
      setLightPos {1000 100 0}
      eyepos=PosXYZ
      eyeori=Orientation

      cs
      drawGraphic landscapegraphic

;      setPosXYZ eyepos
;      setOrientation eyeori
;      setPC rgba 1 1 1 0.2
;      (pcube 100)

      if shadows [enableShadows castShadows]
      updateGraph
      if video [VideoFrame]

      setPosXYZ eyepos
      setOrientation eyeori
      back eyecenter2
      dÏv=dÏ/(1+0.1*Norm v)
      if kup
      [   Ï.1=Ï.1+dÏv
      ]
      if kdown
      [   Ï.1=Ï.1-dÏv
      ]
      if kright
      [   Ï.1=Ï.1+dÏv*0.4
         Ï.2=Ï.2+dÏv
         Ï.3=Ï.3+dÏv
      ]
      if kleft
      [   Ï.1=Ï.1+dÏv*0.4
         Ï.2=Ï.2-dÏv
         Ï.3=Ï.3-dÏv
      ]
      if krr
      [   Ï.3=Ï.3+dÏv
      ]
      if klr
      [   Ï.3=Ï.3-dÏv
      ]
      Ï=Ï*0.95
      up Ï.1
      right Ï.2
      rightroll Ï.3

      up 90
      p0=PosXYZ
      forward 1
      p1=PosXYZ
      back 1
      down 90
      d=p1-p0
      forward 1
      p2=PosXYZ
      back 1
      setTowardsXYZup
         p2
         p0+(p1-p0)*0.98+[0 1 0]*0.02

      if kacc
      [   if v < vmax
         [   dv+=a/(1+0.1*Norm v)
         ]
      ]
      if kbreak
      [   if v > 0
         [   dv-=a/(1+0.1*Norm v)
         ]
      ]
      dv*=0.95
      v+=dv
      if key?
      [   dispatchMessages
         local [ch]
         ch=readChar
         if ch=="s [shadows=not shadows]
         if ch=="f
         [   ifelse isfullscreen [notFullScreen][allFullScreen]
         ]
      ]
      forward v
      z=Int ZCor/rfactor
      y=Int YCor/yfactor
      x=Int XCor/rfactor

      ifelse (abs z) <= r  and2  (abs x) <= r
      [   if y < (p.z).x+miny
         [   setY yfactor*((p.z).x+miny)
            (pr [Ooops!] bf gensym)
            dispatchMessages
         ]
      ][   if x >  r [setX rfactor* r]
         if x < -r [setX rfactor*-r]
         if z >  r [setZ rfactor* r]
         if z < -r [setZ rfactor*-r]
      ]
      forward eyecenter2
      eye=Array PosXYZ
      forward eyecenter
      center=Array PosXYZ
      back eyecenter
      up 90  fd 1
      upvector=(Array PosXYZ)-eye
      upvector/=Norm upvector
      bk 1 down 90
   ]
end

be fly_around_old
   local [eye light center upvector eyepos eyeori]
   center={0 0 0}
   upvector={0 1 0}
   eye=array 3
   light=array 3
   ang=1
   flyspeed=int 1
   dspeed=flyspeed/4
   eyecenter=100
   eyecenter2=eyecenter*2
   shadows=false

   penUp
   eye=Array PosXYZ
   forward eyecenter
   center=Array PosXYZ
   back eyecenter

   print [left, right, up and down rotates, x c rolls, a y changes speed, ESC exits]
   dispatchMessages
   isfullscreen=false
   forever
   [   setEye eye center upvector
      setLightPos {10000 10000 0}
      eyepos=PosXYZ
      eyeori=Orientation

      cs
      drawGraphic landscapegraphic

;      setPosXYZ eyepos
;      setOrientation eyeori
;      setPC rgba 1 1 1 0.2
;      (pcube 100)

      if shadows [enableShadows castShadows]
      updateGraph
      if video [VideoFrame]

      setPosXYZ eyepos
      setOrientation eyeori
      back eyecenter2
      if key?
      [   dispatchMessages
         local [ch]
         ch=readChar
         ifelse ch==char 255
         [   ch=readCharExt
            if ch==WXK_RIGHT [right ang]
            if ch==WXK_LEFT  [ left ang]
            if ch==WXK_UP    [   up ang]
            if ch==WXK_DOWN  [ down ang]
         ][
            if ch==char 27 [break]
            if ch=="a [flyspeed=flyspeed+dspeed]
            if ch=="y [flyspeed=flyspeed-dspeed]
            if ch=="x [ leftRoll ang]
            if ch=="c [rightRoll ang]
            if ch=="s [shadows=not shadows]
            if ch=="f
            [   ifelse isfullscreen [notFullScreen][allFullScreen]
            ]
         ]
      ]
      forward flyspeed
      z=round ZCor/rfactor
      y=round YCor/yfactor
      x=round XCor/rfactor

      ifelse (abs z) <= r  and2  (abs x) <= r
      [   if y < (p.z).x+miny
         [   setY yfactor*((p.z).x+miny)
            (pr [Ooops!] bf gensym)
            dispatchMessages
         ]
      ][   if x >  r [setX rfactor* r]
         if x < -r [setX rfactor*-r]
         if z >  r [setZ rfactor* r]
         if z < -r [setZ rfactor*-r]
      ]
      forward eyecenter2
      eye=Array PosXYZ
      forward eyecenter
      center=Array PosXYZ
      back eyecenter
      up 90  fd 1
      upvector=(Array PosXYZ)-eye
      upvector=upvector/Norm upvector
      bk 1 down 90
   ]
end

to geny
   output maxy*rnd-maxy/2
end

be quad r
   local [p a b c d]
   p=(mdarray List 2*r+1 2*r+1  -r)
   a=(List -r geny -r)
   b=(List -r geny  r)
   c=(List  r geny  r)
   d=(List  r geny -r)
   ignore new_edge a a
   ignore new_edge b b
   ignore new_edge c c
   ignore new_edge d d

   quad2 a b c d 0
;pr p
   output p

   be quad2 a b c d depth
   ;(show a b c d)
      ac=a-c
      if (sqrt (sqr ac.1)+(sqr ac.3)) < minside [stop]
      local [m]
      m=c+(a-c)/2
      m.2=m.2+(a.2-c.2)*(rnd-0.5)
      _setItem Int m.1 p.(Int m.3) m.2

      ignore new_edge a b
      ignore new_edge b c
      ignore new_edge c d
      ignore new_edge d a

      q a b c d
      q b c d a
      q c d a b
      q d a b c

      be q a b c d
         local [bn cn dn]
         bn=new_edge a b
         cn=new_edge a c
         dn=new_edge a d
         quad2  a  bn  cn  dn  depth+1
      end
   end

   be new_edge a b
      local [m py]
      m=b+(a-b)/2
      py=(p.(Int m.3)).(Int m.1)
      ifelse empty? py
      [   m.2=m.2+(a.2-b.2)*(rnd-0.5)
         _setItem Int m.1 p.(Int m.3) m.2
      ][   m.2=py
      ]
      output m
   end
end

to house [size 300]
   local
   [   hsize  hpos hori
      doorwitdh doorheight doorx doorstep doorpos doorori
   ]
   horizon=1e4
   hsize=size/2
   sizey=size/2*(1+sqrt 3)
   wall=hsize/10
   setLightAmbient rgb .4 .4 .4
;   perspective
   hpos=PosXYZ
   hori=Orientation

   pu   down 180  fd hsize  up 90
;   draw_plane
   lt 180  fd hsize  rt 90  fd hsize  lr 90  rt 90
   openpos=[]
   openori=[]
   setpc "white
   enableTexture
   Texture texBricks
   double? = false
   draw_front
   down 90  fd wall  up 90
   double? = true
   draw_front2
   down 90  bk wall  up 90

   down 90  fd size  up 90  lr 90
   double? = false
   draw_side
   down 90  fd wall  up 90
   double? = true
   draw_side2
   down 90  bk wall  up 90
   down 90  fd size  up 90  lr 90
   double? = false
   draw_back
   down 90  fd wall  up 90
   double? = true
   draw_back2
   down 90  bk wall  up 90
   down 90  fd size  up 90  lr 90
   double? = false
   draw_side
   down 90  fd wall  up 90
   double? = true
   draw_side2
   down 90  bk wall  up 90
   fd hsize  down 30  bk wall  lt 90  fd wall  rt 90
   Texture texRooftiles
   draw_roof
   draw_roof2
   fd size+wall  down 120  fd size+wall  rt 90  fd size+2*wall  rt 90
   draw_roof
   draw_roof2
   setPC "white
   Texture texBricks
   draw_openings
   setOrientation hori
   setPosXYZ hpos
;   rotateScene2
end

to double runlist
   double? = false
   run runlist
   down 90  fd wall  up 90
   double? = true
   run runlist
   down 90  bk wall  up 90
end

to add_open
   if not double?
   [   push "openpos posXYZ
      push "openori Orientation
      push "openheight height
      push "openwidth width
   ]
end

to save_pos
   opos=posXYZ
   oori=Orientation
end

to reset_pos
   pu
   setPosXYZ opos
   setOrientation oori
end

to draw_plane
   save_pos
      fd horizon  rt 90  fd horizon  rt 90
   setpc hsb 60 0.3 0.7
   pd  PolyStart  repeat 4 [fd horizon*2  rt 90]  PolyEnd
   reset_pos
end

to draw_openings
   while [not empty? openpos]
   [   setPosXYZ pop "openpos
      setOrientation pop "openori
      width=pop "openwidth
      height=pop "openheight
      rr 90
      pd
      repeat 2
      [   PolyStart
            myTexXY    0 height  fd height  rt 90
            myTexXY wall height  fd wall  rt 90
            myTexXY wall      0  fd height  rt 90
            myTexXY    0      0  fd wall  rt 90
         PolyEnd
         pu fd height  up 90  pd
         PolyStart
            myTexXY    0 width  fd width  rt 90
            myTexXY wall width  fd wall  rt 90
            myTexXY wall     0  fd width  rt 90
            myTexXY    0     0  fd wall  rt 90
         PolyEnd
         pu fd width  up 90  pd
      ]
      pu
   ]
end

to myTexXY x y
   setTexXY 5*x/size 5*y/sizey
end

to drawWindow
   reset_pos
      rt 90  fd winx  lt 90  fd winy
   add_open
   pd
   myTexXY winx       height+winy  fd height  rt 90
   myTexXY winx+width height+winy  fd width  rt 90
   myTexXY winx+width winy         fd height  rt 90
   myTexXY winx       winy         fd width
end

to drawWindow2
   reset_pos
      rt 90  fd winx+width  lt 90  fd winy
   add_open
   pd
   myTexXY winx+width height+winy  fd height  lt 90
   myTexXY winx       height+winy  fd width  lt 90
   myTexXY winx       winy         fd height  lt 90
   myTexXY winx+width winy         fd width
end

to drawFrontOut
   save_pos
   pd
   myTexXY 0      hsize  fd hsize  rt 30
   myTexXY size/2 sizey  fd size  rt 120
   myTexXY size   hsize  fd size  rt 30
   myTexXY size   0      fd hsize rt 90
   myTexXY 0      0      fd size  rt 90
end

to drawFrontOut2
   save_pos
   rightRoll 180
   pd
   myTexXY 0      hsize  fd hsize  lt 30
   myTexXY size/2 sizey  fd size  lt 120
   myTexXY size   hsize  fd size  lt 30
   myTexXY size   0      fd hsize lt 90
   myTexXY 0      0      fd size  lt 90
end

to draw_front
   TessStart
   drawFrontOut

   TessContour
   height=size*3/8
   width=height*1/2
   winx=size/4
   winy=height/8
   drawWindow

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*9/16
   winy=height*6/8
   drawWindow

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*5/16
   winy=hsize+winy
   drawWindow
   TessEnd
   reset_pos
end

to draw_front2
   TessStart
   drawFrontOut2

   TessContour
   height=size*3/8
   width=height*1/2
   winx=size/4
   winy=height/8
   drawWindow2

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*9/16
   winy=height*6/8
   drawWindow2

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*5/16
   winy=hsize+winy
   drawWindow2
   TessEnd
   reset_pos
end

to draw_back
   TessStart
   drawFrontOut

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*1/16
   winy=height*6/8
   drawWindow

   TessContour
   winx=size*9/16
   drawWindow

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*5/16
   winy=hsize+winy
   drawWindow
   TessEnd
   reset_pos
end

to draw_back2
   TessStart
   drawFrontOut2

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*1/16
   winy=height*6/8
   drawWindow2

   TessContour
   winx=size*9/16
   drawWindow2

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*5/16
   winy=hsize+winy
   drawWindow2
   TessEnd
   reset_pos
end

to draw_side
   TessStart
   save_pos
   pd
   myTexXY 0    hsize  fd hsize  rt 90
   myTexXY size hsize  fd size  rt 90
   myTexXY size 0      fd hsize  rt 90
   myTexXY 0    0      fd size  rt 90

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*1/16
   winy=height*6/8
   drawWindow

   TessContour
   winx=size*9/16
   drawWindow
   TessEnd
   reset_pos
end

to draw_side2
   TessStart
   save_pos
   rightRoll 180
   pd
   myTexXY 0    hsize  fd hsize  lt 90
   myTexXY size hsize  fd size  lt 90
   myTexXY size 0      fd hsize  lt 90
   myTexXY 0    0      fd size  lt 90

   TessContour
   height=size*3/12
   width=height*3/2
   winx=size*1/16
   winy=height*6/8
   drawWindow2
   TessContour
   winx=size*9/16
   drawWindow2
   TessEnd
   reset_pos
end

to draw_roof
   pd
   PolyStart
      myTexXY 0           size+wall  fd size+wall    rt 90
      myTexXY size+2*wall size+wall  fd size+2*wall  rt 90
      myTexXY size+2*wall 0          fd size+wall    rt 90
      myTexXY 0           0          fd size+2*wall  rt 90
   PolyEnd
   pu
end

to draw_roof2
   pd
   red=hsb 0 1 1
   setPC red
   right 90
   PolyStart
      myTexXY size+2*wall size+wall  fd size+2*wall  lt 90
      myTexXY size+2*wall 0          fd size+wall    lt 90
      myTexXY 0           0          fd size+2*wall  lt 90
      myTexXY 0           size+wall  fd size+wall    lt 90
   PolyEnd
   left 90
   pu
end