A Brown Ale down at the old Foo

dodicat · Post by **dodicat** » Jun 23, 2008 21:03

This one is on me


Declare Sub rotate(Byval pivot_x As Double,_  'x pivot for rotation
                   Byval pivot_y As Double,_  'y pivot for rotation 
                   Byval first_x As Double,_  'x for line,centre for circle
                   Byval first_y As Double,_  'y for line,centre for circle
                   Byval second_x As Double, _'x for line,radius for circle 
                   Byval second_y As Double, _'y for line,aspect for ciccle
                   Byval angle As Double, _   'angle to rotate-clockwise
                   Byval magnifier As Double,_ '1=no dilation
                   Byval colour As Integer,_   'color for line or circle
                   Byref shape As String) 'line or circle/circlefill box/boxfill point"
            
Dim Shared np(1 To 2) As Double 'For a position rotation only,no drawing
'np(1)= new x, np(2)=new y
'END DECLARATIONS
  'XXXX   a very simple line rotator procedure  XXXX                  
Sub rotate(Byval pivot_x As Double,_
           Byval pivot_y As Double,_
           Byval first_x As Double,_
           Byval first_y As Double,_
           Byval second_x As Double, _
           Byval second_y As Double, _
           Byval angle As Double, _
           Byval magnifier As Double,_
           Byval colour As Integer,_
           Byref shape As String)
           
Dim p As Double = 4*Atn(1)  '(pi)
Dim angle_degrees As Double
Dim line_xvector As Double
Dim line_yvector As Double
Dim pivot_xvector As Double
Dim pivot_yvector As Double
angle_degrees=(2*p/360)*angle      'change from radians to degrees
pivot_xvector=first_x-pivot_x
pivot_yvector=first_y-pivot_y
Dim mover(1 To 2,1 To 2) As Double
Dim new_pos(1 To 2) As Double
mover(1,1)=Cos(angle_degrees)
mover(2,2)=Cos(angle_degrees)
mover(1,2)=-Sin(angle_degrees)
mover(2,1)=Sin(angle_degrees)

line_xvector=magnifier*(second_x-first_x)                   'get the vector
line_yvector=magnifier*(second_y-first_y)                   'get the vector

new_pos(1)=mover(1,1)*pivot_xvector+mover(1,2)*pivot_yvector +pivot_x
new_pos(2)=mover(2,1)*pivot_xvector+mover(2,2)*pivot_yvector +pivot_y
Dim new_one(1 To 2) As Double            'To hold the turned value

new_one(1)=mover(1,1)*line_xvector+mover(1,2)*line_yvector +first_x
new_one(2)=mover(2,1)*line_xvector+mover(2,2)*line_yvector +first_y
Dim xx As Double   'translation
Dim yy As Double 
xx=first_x-new_pos(1)
yy=first_y-new_pos(2)
Select Case shape
Case "line"
 Line(first_x-xx,first_y-yy)-(new_one(1)-xx,new_one(2)-yy),colour 
Case "circle"
 Circle(first_x-xx,first_y-yy),magnifier*second_x,colour,,,second_y
Case "circlefill"
 Circle(first_x-xx,first_y-yy),magnifier*second_x,colour,,,second_y,F
 Case"box"
 
 Line(first_x-xx,first_y-yy)-(new_one(1)-xx,new_one(2)-yy),colour,b
Case "boxfill"
 Line(first_x-xx,first_y-yy)-(new_one(1)-xx,new_one(2)-yy),colour,bf
Case "point"
 np(1)=new_one(1)-xx  'new x
 np(2)=new_one(2)-yy   'new y
Case Else
 Print "unknown shape"
 End Select
End Sub

'ROTATOR EXAMPLE
screenres 500,520,32
Windowtitle "BEST BROWN"
const as double red=90
const as double green=90
const as double blue=150
dim shared background as single
background =cint(rgb(red,green,blue))
dim shared as double np1,np2
dim shared flag as integer
dim shared t as double
 dim shared  h as double
t=.275
line(0,0)-(500,550),background,bf
declare sub froth (npi as double,np2 as double,sz as double,m as double)
declare sub pour(message as string)
declare sub small_bubbles(sz as double,ma as double)
declare sub foam (np11 as double,np22 as double,sz as double,m as double)   
declare sub move_fleck(b as double)
declare Function rnd_range (first As Double, last As Double) As Double
declare sub set_bubbles(np1 as double,np2 as double,yval as double,msg as string)
type foamy_bit
    as double foamstart
    as double foamend
end type
sub foo
    dim as single colour
    colour=cint(rgb(red-100,green,blue))
    for a as double=0 to 360 step .1
    if a>350 and a<360 then
rotate(0,150,300,150,310,150,a,1,colour,"line")
end if
next a
for a as double=0 to 360 step .1
    if a>355 and a<360 then
    rotate(300,-250,300,95,300,105,a,1,colour,"line")
    end if
next a
for a as double=0 to 360 step .01
   if a>357 and a<360 then
    rotate(300,-250,300,115,300,125,a,1,colour,"line")
    end if 
next a
for a as double=0 to 360 step .01
    rotate(345,125,350,125,360,125,a,1,colour,"line")
next a
for a as double=0 to 360 step .01
    rotate(385,125,390,125,400,125,a,1,colour,"line")
    next a
for a as double=0 to 360 step .1
    if a>350 and a<360 then
rotate(0,230,360,230,367,230,a,1,colour,"line")
end if
next a
for a as double=0 to 360 step .1'end b
rotate(375,213,385,212,390,212,a,1,colour,"line")
next a

for a as double=0 to 360 step .1'a
rotate(410,213,420,212,425,212,a,1,colour,"line")
next a

for a as double=0 to 360 step .1
    if a>356 and a<360 then
rotate(0,228,423,228,428,228,a,1,colour,"line")
end if
next a

for a as double=0 to 360 step .1 'start r
    if a>356 and a<360 then
rotate(0,230,440,230,447,230,a,1,colour,"line")
end if
next a

for a as double=260 to 330 step .1'a
rotate(450,213,460,212,465,212,a,1,colour,"line")
next a

    end sub
sub fill (message as string)
Dim size As Double
size=100'80
np(1)=250
np(2)=250
Dim As Double a2,stepper,divisor,mag,stepper2,k
mag=1
divisor=1.4118
stepper=.01
if message="beer" then stepper2=-.005
if message="edges" then stepper2=-.005
if message="glass" then stepper2=-.05
Dim As Single a
dim r as double 
dim colour as integer
dim m as integer
dim bottom as single
if message="beer" then bottom=1.4
if message="edges" then bottom=1.8
if message="glass" then bottom=1.4
 For b As Single=bottom To -.1 Step stepper2 'the glass span
     rotate(-9000,400,250,250,250,250,b,0,0,"point")
  m=100*b  
  if message="beer" then
     if np(2)>234.3 then
 small_bubbles size,mag
end if
end if
 r=100
 dim g as double=20
 if message="beer" then
     h=h+.171 
 if np(2)>239 then froth np(1),np(2)+5,size,mag
 end if
 
For a =0 To 180 Step stepper 
    if message="glass" then
      mag=  mag+.000001
      else
    mag=mag+.0000001
    end if
    a2=a
    if message="beer" then
        
            if np(2)>234.3 then
       if a > 90.02080 and a<90.03080 then
           foam (np(1),np(2)+5,size,mag)
           small_bubbles size,mag
       end if
       end if
       
    if a mod 30=0 then  move_fleck(b) 
   if a mod 20=0 then set_bubbles(np(1)-10,np(1)+14,np(2)+rnd_range(-10,5),"white") 
     colour=rgb(a2,g,0)  'beer   
    rotate(np(1),np(2),np(1),np(2),np(1)+size,np(2),a,mag,colour,"line")
end if  'beer
if message="glass" then
    k=-.4*(a2-1)/179+1.2  'near background
    colour=rgb(red/k,green/k,blue/k)
    rotate(np(1),np(2),np(1),np(2),np(1)+size,np(2),a,mag,colour,"line")
    end if

Next a
if message="edges" then
    dim n as integer=1
    for n as integer=1 to 2
    pset (np(1)+mag*size+3+n-15,np(2)),rgb(red-20,green-20,blue-20)
    pset (np(1)-mag*size-4-n+15,np(2)),rgb(red+20,green+20,blue+20)
next n
    end if
Next b
end sub
sub pour(message as string)
    
    dim as double a,b,stepper,size,mag,a2,farpoint,ypoint
    dim as integer colour
    farpoint=-1000
    ypoint=400
    stepper=2
    size=10
    mag=1
    dim g as double=20
    dim as double start,finish
    if message="fill" then 
        start=10
        finish=-12
    end if
    if message="stop" then
        start=-3.5'-1.5
        finish=-8.2
    end if
    if flag=1 then
               start=-3.5'-1.2
        finish=-8.2
        farpoint=-1000
        ypoint=400
           mag=.1
           end if
    For b =start To finish Step -.05
        rotate(farpoint,ypoint,250,250,250,250,b,0,0,"point")
    
        for a=1 to 180 step stepper
            a2=a
            if message="fill" then
            if b<-10 then
                mag=4
                colour= rgb(a2/2,a2/2,a2/2)
            end if
            if b>=-10 then
                mag=1
                if flag=1 then mag=.1
                colour=rgb(.6*a2,g,0)
            end if
            if b > -1.2 then
                colour=rgb(.6*a2+20,g+5,20)
                mag=1
                end if
           
    if b>-10 then rotate(np(1),np(2),np(1),np(2),np(1)+size,np(2),a-40,mag,colour,"line") 
         rotate(np(1),np(2),np(1),np(2),np(1)+size,np(2),a,mag,colour,"line")
     end if  'fill
     if message="stop" then
         flag=1
         rotate(np(1),np(2),np(1),np(2),np(1)+size+5,np(2),a,mag,background,"line")
         end if 'stop
        next a
    next b
    
end sub
Function rnd_range (first As Double, last As Double) As Double
    Function = Rnd * (last - first) + first
End Function
sub set_bubbles(np1 as double,np2 as double,yval as double,msg as string)
   static x(1 to 10) as double
   static yy(1 to 10) as double
   dim y as double =yval
   dim m as integer
   dim colour as single
   if msg="white" then colour=cint(rgb(200,100,100))
       for m =1 to 10
        x(m)=rnd_range(np1+12,np1+17)
       next m
       
   for m=1 to 10
  if yval>240 then pset(x(m),yy(m)),rgb(120,20,0) 
   x(m)=x(m)+rnd_range(-.5,.5)
       yy(m)=y+rnd_range(1,10)+10
   if msg="white" then
       if yval>240 then
   pset(x(m),yy(m)),colour
        end if
   end if
next m

    end sub
    sub froth (np11 as double,np22 as double,sz as double,m as double)
        dim as double a,k,r,k2
        dim as integer colour
        static limit as double
        dim as double l
        
        limit=limit+.0341
        l=2+limit
        np2=np22-5
        np1=np11
        
        for a=-12 to 192 step 1
            
            if a<-5 or a>185 then
            
            k=104*(a+15)/215+150
            colour=rgb(k,k,k)    
           rotate(np1,np2,np1,np2,np1+sz,np2,a,1.05*m,colour,"line")     
        end if
    next a
    
    end sub
    sub move_fleck(b as double)
        dim f as foamy_bit
        dim k as double
        k=-8.8e-2*(b-.1)+.18
        static as double laststart,lastend
        with f
            .foamstart=t
            .foamend=t-.005
        end with
        if laststart<.15 then
         circle(-1000,420),1256,rgb(120,0,0),lastend,laststart,1 
         else
  circle(-1000,420),1256,rgb(100,0,0),lastend,laststart,1 
  end if
circle(-1000,420),1256,rgb(200,20,20),f.foamend,f.foamstart,1'99
lastend=f.foamend
laststart=f.foamstart
        t=(t-.0001*2)
        if t<k then t=.275
    end sub
 sub foam (np11 as double,np22 as double,sz as double,m as double)
     dim as double a,k,r,k2
     
     if h>.1 then 
       for a=-11.075 to 11.075 step .01
      
           k2=-100*(a+11)/22 +255
           if h>25 then
               if a>-5 and a<5 then
           r=3.5
       end if
       end if
    rotate(250,1000,np11,np22-20+r,np11,np22-h,a,1,rgb(k2,k2,k2),"line")
       next a
       end if 'h>
  end sub 
  sub small_bubbles(sz as double,ma as double)
dim as double m,n,xl,xh,k
dim as single colour
colour=rgb(200,0,0)
xl=250-sz*ma:xh=250+sz*ma-5
for m=np(2)-.5 to np(2)+4
    for n=xl to xh step 5
        k=-180*(n-xl)/(xh-xl)+200
   pset(n+rnd_range(1,5),m),rgb(k,20,20)     
    next n
next m
end sub
 
#include once "windows.bi"
sub bar 'FOR linux, bar is the only bit that uses windows.bi
    'Get rid of it and the call on the last line
    messagebox(NULL,"The FOO bar is the place to be","CHEERS",MB_OK)
end sub

  foo
fill "glass"
fill "edges"
pour "fill"
fill "beer" 
pour "stop"
pour "fill"
sleep 600
pour "stop"
for a as integer=-2 to 180 'drip
    dim colour as integer
    colour=rgb(a,20,0)
    rotate(np(1)-3,np(2)+1,np(1)-3,np(2)+1,np(1)-3+15,np(2)+1,a,.7,colour,"line")
next a
bar
'Sleep use for linux

cha0s · Post by **cha0s** » Jun 23, 2008 21:44

It tastes better when it's free...

KristopherWindsor · Post by **KristopherWindsor** » Jun 23, 2008 23:07

HD_ · Post by **HD_** » Jun 24, 2008 8:32

I was impressed to be honest ;)

bfuller · Post by **bfuller** » Jun 25, 2008 23:21

Very Clever.

I had to insert Dim b as Double in line 207 to make it work.

Code: Select all

    End If
    Dim b as Double   
    If a Mod 30=0 Then  move_fleck(b)

EDIT:
OOPs, no I don't. I inadvertently had "-lang deprecated" set in FBIde settings. Works fine as is with "-lang fb"