rem Fractal Foliage ....... Rev 4.1
      rem A J Tooth // 3rd January 2004 Modified 17th February 2004
      on error if (err=17) then quit
      
      *FLOAT64
      proc_fullscreen(xscreen%,yscreen%)
      
      rem Enter parameters
      proc_params
      
      cls
      *REFRESH OFF
      rem Initial Conditions
      x1=0 : y1=0 : x2=2*xscreen% : y2=2*yscreen%
      
      proc_next(x1,y1,x1,y2,x2,y2,x2,y1,lev%) : rem Draw the IFS
      
      *REFRESH ON
      colour 3 : print tab(0,0);"Press -d- to find the Fractal Dimension."
      print tab(0,1);"Press -Space- to re-RUN, or Esc or any other key to QUIT."
      a$=get$ : if a$=" " then run
      print tab(0,0);"                                        "
      print tab(0,1);"                                                          "
      
      if a$="d" then proc_fracdim
      quit
      end
      
      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 Draw the IFS
      def proc_next(X1,Y1,X2,Y2,X3,Y3,X4,Y4,lv%)
      local a%,TX1,TY1
      
      lv%-=1 : rem Reduce the level by 1
      
      for a%=1 to Num%
        sys "GetCurrentProcess" to hprocess%
        sys "SetPriorityClass", hprocess%, &100
        TX1=X1 + (X2-X1)*fac
        TY1=Y1 + (Y2-Y1)*fac
        X2 =X2 + (X3-X2)*fac
        Y2 =Y2 + (Y3-Y2)*fac
        X3 =X3 + (X4-X3)*fac
        Y3 =Y3 + (Y4-Y3)*fac
        X4 =X4 + (X1-X4)*fac
        Y4 =Y4 + (Y1-Y4)*fac
        X1=TX1 : Y1=TY1
        sys "GetCurrentProcess" to hprocess%
        sys "SetPriorityClass", hprocess%, &20
        
        if lv%=0 then
          Val%=int(235*a%/Num%)
          case cl% of
            when 1 : Col%=int(20+120*br%+(Val%/(1+br%))) : vdu 19,2,16,0,Col%,0
            when 2 : Col%=int(235-Val%) : vdu 19,2,16,Val%,Col%,0
          endcase
          gcol 2
          move X1,Y1 : move X2,Y2
          plot 117,X3,Y3
        else
          proc_split(X1,Y1,X2,Y2,X3,Y3,X4,Y4,lv%)
        endif
      next a%
      *REFRESH
      lv%+=1 : rem Increase the level by 1
      endproc
      rem ============================================================
      
      rem Splits each region into 4
      def proc_split(X1,Y1,X2,Y2,X3,Y3,X4,Y4,Lv%)
      local q11x,q11y,q22x,q22y,q33x,q33y,q44x,q44y
      local q12x,q12y,q13x,q13y,q14x,q14y,q21x,q21y,q23x,q23y,q24x,q24y
      local q31x,q31y,q32x,q32y,q34x,q34y,q41x,q41y,q42x,q42y,q43x,q43y
      
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &100
      
      q11x=X1 : q11y=Y1
      q22x=X2 : q22y=Y2
      q33x=X3 : q33y=Y3
      q44x=X4 : q44y=Y4
      
      q12x=X1+((X2-X1)/2) : q12y=Y1+((Y2-Y1)/2)
      q21x=q12x : q21y=q12y
      
      q13x=X1+((X2-X1)/2)+((X4-X1)/2) : q13y=Y1+((Y2-Y1)/2)+((Y4-Y1)/2)
      q31x=q13x : q31y=q13y
      q24x=q13x : q24y=q13y
      q42x=q13x : q42y=q13y
      
      q23x=X2+((X3-X2)/2) : q23y=Y2+((Y3-Y2)/2)
      q32x=q23x : q32y=q23y
      
      q34x=X3+((X4-X3)/2) : q34y=Y3+((Y4-Y3)/2)
      q43x=q34x : q43y=q34y
      
      q14x=X1+((X4-X1)/2) : q14y=Y1+((Y4-Y1)/2)
      q41x=q14x : q41y=q14y
      sys "GetCurrentProcess" to hprocess%
      sys "SetPriorityClass", hprocess%, &20
      
      case cs% of
        when 1 :
          proc_next(q11x,q11y,q12x,q12y,q13x,q13y,q14x,q14y,Lv%)
        when 2 :
          proc_next(q11x,q11y,q12x,q12y,q13x,q13y,q14x,q14y,Lv%)
          proc_next(q31x,q31y,q32x,q32y,q33x,q33y,q34x,q34y,Lv%)
        when 3 :
          proc_next(q21x,q21y,q22x,q22y,q23x,q23y,q24x,q24y,Lv%)
          proc_next(q31x,q31y,q32x,q32y,q33x,q33y,q34x,q34y,Lv%)
          proc_next(q41x,q41y,q42x,q42y,q43x,q43y,q44x,q44y,Lv%)
        when 4 :
          proc_next(q11x,q11y,q12x,q12y,q13x,q13y,q14x,q14y,Lv%)
          proc_next(q21x,q21y,q22x,q22y,q23x,q23y,q24x,q24y,Lv%)
          proc_next(q31x,q31y,q32x,q32y,q33x,q33y,q34x,q34y,Lv%)
          proc_next(q41x,q41y,q42x,q42y,q43x,q43y,q44x,q44y,Lv%)
      endcase
      
      endproc
      rem ============================================================
      
      rem Enter parameters
      def proc_params
      
      print:input" Enter number of iterations (12)",Num%
      if Num%=0 then Num%=12
      print:input" Enter Contractivity Factor (0.15)",fac
      if fac=0 then fac=0.15
      print:input " Enter number of levels (4)",lev%
      if lev%=0 then lev%=4
      print:input " Choose 1,2,3 or 4 quadrants (1)",cs%
      if cs%=0 then cs%=1
      print:input " Choose 1 or 2 colours (1)",cl%
      if cl%<>2 then cl%=1
      if cl%=1 then
        print:input " Choose light -l- or dark -d- for single colour.",c$
        if c$<>"l" then c$="d"
        if c$="l" then br%=1 else br%=0
      endif
      endproc
      rem ============================================================
      
      rem Estimates the Fractal Dimension of the picture
      def proc_fracdim
      local j%,k%,xe%,ye%
      
      dim rgb% 3
      dim Cnt%(4)
      
      rem Change the current Directory
      command$="CD "+chr$(34)+@dir$+chr$(34)
      oscli command$
      
      *SCREENSAVE Screen.bmp
      clg
      gcol 1
      
      for m%=3 to 1 step -1
        *DISPLAY Screen.bmp
        n%=2^m%
        for j%=0 to (2048/n%)
          for k%=0 to (1536/n%)
            
            xe%=n%*j% + (n%/2) : ye%=n%*k% + (n%/2)
            
            !rgb%=tint(xe%,ye%)
            r&=?rgb%
            g&=rgb%?1
            b&=rgb%?2
            
            if (r&+256*g&+65536*b&)>255 then rectangle fill (xe%-m%),(ye%-m%),n%,n% : Cnt%(m%)+=1
            
          next k%
        next j%
        
        colour 6 : print tab(5,5);"Number of Covered Elements = ";Cnt%(m%)
        print tab(5,6);"Press any key to continue."
        a$=get$
      next m%
      DY1=ln(Cnt%(1)) - ln(Cnt%(3))
      DX1=ln(128) - ln(32)
      
      print tab(5,7);"Fractal Dimension Estimate is ... ";(int(100*DY1/DX1))/100
      
      a$=get$
      endproc
      rem ============================================================