rem IFS Fractal Trees .... Rev 3.2
      rem A J Tooth // 18th July 2005
      
      rem ======================================================================
      rem Vastly improved Fractal Tree implementation.
      rem ======================================================================
      
      rem Preamble==================================
      on error if (err=17) then quit
      *FLOAT 64
      himem=lomem + 5000000
      install @lib$+"MyUtils.bbc"
      rem Preamble==================================
      
      rem Go to full screen
      proc_fullscreen(xscreen%,yscreen%)
      
      rem Initial Object
      proc_init
      
      rem Displays a bacground jpg and my icon in compiled version
      Pic$=@dir$ + "BgroundW.jpg"
      proc_dispBack(Pic$,0,0,xscreen%,yscreen%)
      proc_AJTicon(10,fn_adapt(1,650))
      
      rem Object
      proc_drwObject(linS,angS,xs%,ys%,levelS&)
      
      proc_AJTicon(10,fn_adapt(1,650))
      a$=fn_cont
      if a$=" " then run else 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 Initial Object
      def proc_init
      origin xscreen%,0 : colour 132,0,0,50 : colour 8,160,90,20
      
      rem Title page background
      Pic$=@dir$ + "Tree.jpg"
      proc_dispBack(Pic$,0,0,xscreen%,yscreen%)
      proc_AJTicon(10,fn_adapt(1,650))
      
      msg$="\8FRACTAL TREES"
      proc_msg("Blackadder ITC",24,"B",fn_adapt(0,300),fn_adapt(1,300),msg$)
      
      rem Instructions
      msg$="\2Just press -\1Enter\2- to select the default value in brackets."
      proc_msg("Verdana",12,"B",50-xscreen%,fn_adapt(1,1500),msg$)
      
      msg$="What initial line-length? (400) "
      par=fn_param(msg$,3)
      if par<1.0 then par=400.0
      linS=par
      
      msg$="What line reduction factor? (0.7) "
      par=fn_param(msg$,5)
      if par<0.05 then par=0.7
      red=par
      
      msg$="What initial Angle? (0) "
      par=fn_param(msg$,7)
      angS=par
      
      msg$="Left-hand factor? (0.3) "
      par=fn_param(msg$,9)
      if par<0.01 or par>1.0 then par=0.3
      lhf=par
      
      msg$="Right-hand factor? (0.7) "
      par=fn_param(msg$,11)
      if par<0.01 or par>1.0 then par=0.7
      rhf=par
      
      msg$="Sequential Angle Change? (30) "
      par=fn_param(msg$,13)
      if par<0.01 then par=30.0
      dAng=par
      
      msg$="Systematic Angle Change? (0) "
      par=fn_param(msg$,15)
      sAng=par
      
      msg$="Number of Levels? (8) "
      par=fn_param(msg$,17)
      if par<0.5 then par=8.5
      levelS&=int(par+0.1)
      
      msg$="With or without LEAVES? (y/n - default is 'y') "
      rem Parameter input
      colour 3:print tab(5,19);msg$;
      colour 1
      L$=get$
      if L$<>"n" then L$="y"
      print;L$
      
      P$="r"
      if L$="y" then
        msg$="Round or pine-LEAVES? (r/p - default is 'r') "
        rem Parameter input
        colour 3:print tab(5,21);msg$;
        colour 1
        P$=get$
        if P$<>"p" then P$="r"
        print;P$
      endif
      
      msg$="With or without a VERTICAL BRANCH? (y/n - default is 'y') "
      rem Parameter input
      colour 3:print tab(5,23);msg$;
      colour 1
      B$=get$
      if B$<>"n" then B$="y"
      print;B$
      
      msg$="With or without 2 SUB-BRANCHes? (y/n - default is 'n') "
      rem Parameter input
      colour 3:print tab(5,25);msg$;
      colour 1
      S$=get$
      if S$<>"y" then S$="n"
      print;S$
      
      msg$="With or without a TRUNK ? (y/n - default is 'y') "
      rem Parameter input
      colour 3:print tab(5,27);msg$;
      colour 1
      Trnk$=get$
      if Trnk$<>"n" then Trnk$="y"
      print;Trnk$
      
      if Trnk$="y" then
        msg$="Finest twig size? (v=visible/f=fine - default is 'visible') "
        colour 3:print tab(5,29);msg$;
        colour 1
        Ff$=get$
        if Ff$<>"f" then Ff$="v"
        print;Ff$
        if Ff$="f" then ff=0.1 else ff=0.15
      else
        ff=0.15 : rem Not used, but not left undefined
      endif
      
      xs%=0 : ys%=200 : rem Initial start point always near bottom centre of screen
      
      a$=inkey$(30)
      
      cls
      endproc
      rem =============================================================
      
      rem Object
      def proc_drwObject(Lin,Ang,Xs%,Ys%,Lev&)
      local Xe%,Ye%
      
      rem Colour setting
      if Lev&=1 then md&=rnd(100) else md&=4*Lev&
      colour 10,160-md&,100-md&,30 : gcol 10
      
      Xe%=Xs% + int(Lin*sin(rad(Ang)))
      Ye%=Ys% + int(Lin*cos(rad(Ang)))
      
      rem Final colour is green if pine-leaves selected
      if (Lev&=1 and L$="y" and P$="p") then colour 10,100,100+rnd(155),0 : gcol 10
      
      if Trnk$="y" then
        rem Draws a reducing-width "trunk"
        fac=Lev&/levelS&  : if fac<ff then fac=ff
        R=sqr((Xe%-Xs%)^2 + (Ye%-Ys%)^2) : if R<0.001 then R=0.001
        Dx%=int(fac*15*(Ye%-Ys%)/R) : Dy%=int(fac*15*(Xs%-Xe%)/R)
        Bx%=Xs% + Dx% : By%=Ys% + Dy%
        
        move Bx%,By% : move Xs%,Ys% : plot 117,Xe%,Ye%
        Bx%=Xs% - Dx% : By%=Ys% - Dy%
        move Xs%,Ys% : plot 117,Bx%,By%
      else
        rem Just draws a line
        move Xs%,Ys% : draw Xe%,Ye%
      endif
      rem Draw LEAVES if required
      if (Lev&=1 and L$="y" and P$="r") then colour 10,100,100+rnd(155),0 : gcol 10 : circle fill Xe%,Ye%,10
      
      Lev&-=1 : rem Go down a level
      
      if Lev&>0 then
        rem New Objects
        proc_newObjects(Lin,Ang,Xs%,Ys%,Xe%,Ye%,Lev&)
      endif
      
      Lev&+=1 : rem Go back up a level
      endproc
      rem =============================================================
      
      rem New Object
      def proc_newObjects(Lin,Ang,Xs%,Ys%,Xe%,Ye%,Lev&)
      local Xt%,Yt%,scnd
      
      Lin=red*Lin : rem Reduce the line length for the new object
      
      rem Draw the objects
      rem Branch 1
      Xt%=Xs% + int(lhf*(Xe%-Xs%)): Yt%=Ys% + int(lhf*(Ye%-Ys%))
      proc_drwObject(Lin,Ang+sAng-dAng,Xt%,Yt%,Lev&)
      rem Branch 2
      Xt%=Xs% + int(rhf*(Xe%-Xs%)): Yt%=Ys% + int(rhf*(Ye%-Ys%))
      proc_drwObject(Lin,Ang+sAng+dAng,Xt%,Yt%,Lev&)
      rem Branch 3 (if specified)
      if B$="y" then
        Xt%=Xe%: Yt%=Ye%
        proc_drwObject(Lin,Ang+sAng,Xt%,Yt%,Lev&)
      endif
      
      rem Two further sub-branches, if specified
      if S$="y" then
        scnd=2*lhf-lhf*lhf
        Xt%=Xs% + int(scnd*(Xe%-Xs%)): Yt%=Ys% + int(scnd*(Ye%-Ys%))
        proc_drwObject(Lin/2,Ang+sAng-dAng,Xt%,Yt%,Lev&)
        scnd=2*rhf-rhf*rhf
        Xt%=Xs% + int(scnd*(Xe%-Xs%)): Yt%=Ys% + int(scnd*(Ye%-Ys%))
        proc_drwObject(Lin/2,Ang+sAng+dAng,Xt%,Yt%,Lev&)
      endif
      endproc
      rem =============================================================
      
      rem Parameter input
      def fn_param(Msg$,Yps&)
      
      colour 3:print tab(5,Yps&);Msg$;
      colour 1:input;cin;
      =1.0*cin
      rem =============================================================
      
      rem Continue routine
      def fn_cont
      local a$,x,y,m&
      
      msg$="\2Finished. Press -\3spacebar\2- or -\3Enter\2- or left-click to \3RUN \2again. Any other key or right-click to \1QUIT\2."
      proc_msg("Verdana",12,"B",50-xscreen%,fn_adapt(1,100),msg$)
      
      a$=""
      repeat
        mouse x,y,m&
        a$=inkey$(1)
        if m&=4 then a$=" "
        if asc(a$)=13 then a$=" "
        if m&=1 then a$="x"
      until a$<>""
      =a$
      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 ===============================================================
      
      rem Display title page background
      def proc_dispBack(picture$,xpos%,ypos%,xsize%,ysize%)
      local oleaut32%, olpp%, iid%, gpp%, hmw%, hmh%, picture%, Len%, res%
      
      sys "LoadLibrary", "OLEAUT32.DLL" to oleaut32%
      sys "GetProcAddress", oleaut32%, "OleLoadPicturePath" to olpp%
      if olpp%=0 error 0, "Could not get address of OleLoadPicturePath"
      
      dim iid% local 15, picture% local 513
      sys "MultiByteToWideChar", 0, 0, picture$, len(picture$), picture%, 256 to Len%
      picture%!(2*Len%) = 0
      
      iid%!0  = &7BF80980
      iid%!4  = &101ABF32
      iid%!8  = &AA00BB8B
      iid%!12 = &AB0C3000
      
      sys olpp%, picture%, 0, 0, 0, iid%, ^gpp%
      if gpp% = 0 error 0, "OleLoadPicturePath failed"
      
      sys !(!gpp%+24), gpp%, ^hmw% : rem. IPicture::get_Width
      sys !(!gpp%+28), gpp%, ^hmh% : rem. IPicture::get_Height
      sys !(!gpp%+32), gpp%, @memhdc%, xpos%, ypos%, xsize%, ysize%, 0, hmh%, hmw%, -hmh%, 0 to res%
      if res% error 0, "IPicture::Render failed"
      
      sys !(!gpp%+8), gpp% : rem. IPicture::Release
      sys "InvalidateRect", @hwnd%, 0, 0
      sys "UpdateWindow", @hwnd%
      endproc
      rem ================================================================