rem Fractal Land ...... Rev 2.0
      rem A J Tooth / 22nd June 2003
      rem Revised December 2007
      
      on error if (err=17) then quit
      
      *FLOAT 64
      rem Set up use of Full Screen
      proc_fullscreen(xscreen%,yscreen%)
      
      rem Parameter Setup
      Xlim%=2*xscreen% : Ylim%=2*yscreen%
      
      rem Choose the colour range
      proc_colran : cls
      
      Max%=500
      rem Set up Land Array
      dim Land%(Xlim%,2)
      
      stp%=0
      repeat
        repeat
          
          rem Reset parameters
          proc_reset
          
          rem Perturb the line
          proc_perturb
          
          *REFRESH OFF
          rem Print landscape to screen
          proc_landdisp(a$)
        until a$<>""
        
        *REFRESH ON
        
        sp$=get$
      until sp$<>"c"
      if sp$="r" then run else quit
      rem End of Program ===========================================================
      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 PROC 2
      rem Sets Colour Range
      def proc_colran
      
      *FONT Verdana,16
      print tab(5,5);" Select base colour. Enter r,g or b. "
      repeat
        bs$=get$
      until bs$="r" or bs$="g" or bs$="b"
      
      print tab(5,7);" Select low(1), medium(2) or high(3) intensity. Enter 1,2 or 3. "
      repeat
        in$=get$
      until in$="1" or in$="2" or in$="3"
      in%=eval(in$)
      
      print tab(5,9);" Using the same colour for base and range is OK."
      print tab(5,10);" Enter ranging colour (r,g or b). "
      repeat
        rn$=get$
      until rn$="r" or rn$="g" or rn$="b"
      
      gr%=16
      endcase
      
      case bs$ of
      when "r" : Red&=64*in% : Green&=0      : Blue&=0
      when "g" : Red&=0      : Green&=64*in% : Blue&=0
      when "b" : Red&=0      : Green&=0      : Blue&=64*in%
      endcase
      endproc
      rem ==========================================================================
      
      rem Reset parameters
      def proc_reset
      local c%
      
      rem Set end-points
      ys%=200+rnd(1000) : ye%=200+rnd(1000)
      Land%(0,0)=ys% : Land%(Xlim%,0)=ye%
      Land%(0,1)=1   : Land%(Xlim%,1)=1
      
      rem Clear down mid-points
      for c%=1 to Xlim%-1
      Land%(c%,0)=0
      Land%(c%,1)=0
      next c%
      
      lp%=1
      frst%=0
      rem Set exponential reduction factor
      fact=1.5+rnd(1)
      
      endproc
      rem ==========================================================================
      
      rem Perturb the line
      def proc_perturb
      
      repeat
      rem Reduce max perturbation with each loop.
      red%=(fact)^lp%
      cnt%=frst%+1 : scnd%=-1
      rem Find the next perturbed point
      repeat
      if Land%(cnt%,1)=1 then scnd%=cnt% else cnt%+=1
      until (cnt%>Xlim% or scnd%>0)
      
      rem If there ARE still mid-points, select a mid-point
      if (scnd%-frst%)>1 then
      midl%=int((scnd%+frst%)/2)
      rem Perturb the landscape up or down
      sw%=(2*(rnd(2)-1))-1
      pert%=sw%*rnd(int(Max%/red%))
      Land%(midl%,1)=1
      Land%(midl%,0)=int(((Land%(frst%,0)+Land%(scnd%,0))/2)+pert%)
      endif
      rem Start again when end-point reached
      if frst%<(Xlim%-1) then
      if scnd%=Xlim% then
        frst%=0 : lp%+=1
      else
        frst%=scnd%
      endif
      endif
      until frst%=(Xlim%-2)
      endproc
      rem ==========================================================================
      
      rem Print landscape to screen
      def proc_landdisp(return a$)
      local a%,b%
      
      rem Selects colour to use
      ntn&=stp%
      case rn$ of
      when "r" : Red&=ntn&
      when "g" : Green&=ntn&
      when "b" : Blue&=ntn&
      endcase
      
      a$=""
      for a%=0 to Xlim%
      cur%=Land%(a%,0)
      move a%,cur%
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &100
      if cur%>0 then
      for b%=cur% to 0 step -10
        rem Continually reassigns Colour 10 to be the new hue
        Rd&=int(Red&*(b%/cur%))
        Grn&=int(Green&*(b%/cur%))
        Blu&=int(Blue&*(b%/cur%))
        colour 10,Rd&,Grn&,Blu& : gcol 0,10
        draw a%,b%
      next b%
      endif
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &20
      
      *REFRESH
      next a%
      
      rem End of Main Body
      a$=inkey$(1)
      stp%+=30 : if stp%>255 then stp%=0
      endproc
      rem ==========================================================================