Pentacles

[Richard]

Well, the thread Circles went around in circles, until it got dizzy, then Circles got squared. I am sure attempts to square the circle, by square programmers will continue. The Squares thread should logically progress to either Triangles or Pentagons, so how about triangles and a pentagon?

New-age and post-modernist semiotics are always confusing me. Unlike the tentacle, the pentacle is a fundamental symbol of mankind, and of the unkind. Like black and white witches, Wicca pentacles have been around for thousands of years, and have taken on many contradictory and magical meanings. You can both hate them and love them at the same time. I love the geometry of the symbol, but I reject several of the things it can stand for.
https://en.wikipedia.org/wiki/Pentacle

When you don't know why your post-modernist code functions you must trust in a higher being, the Earth. As we are nurtured by the crystal fields from our Earth, we must continue to write code that actually works.

Here, to set the ball rolling I post a simulation of Alchemy and Earth Magic.

Code: Select all

' Transmutation of the elements. See course notes: Alchemy 101.
Screen 19
Window( -1.5, -1.2 )-( 1.5, 1.2 )

' first transmute lead into gold and silver.
Dim As Double Pb = ( Sqr( 5 ) + 1 ) / 2     ' lead, a gold ratio isotope
Dim As Double Au = Sqr( 1 - Pb / 4 * Pb )   ' gold, by fusion of lead
Dim As Double Ag = Pb /- 2                  ' silver, by fission of lead

' simulate Earth's dynamic crystal field
Dim As Double Si = 14       ' atomic number of the silicon catalyst
Dim As Double Hg, Fe, Ni=1  ' mercury, iron & nickle in Earth's core
Pset( Fe, Ni ), Hg          ' set the start of reaction
For i As Integer = 0 To 4   ' convect mantle for 0 to 4 billion years
    Fe = Ag * Fe - Au * Ni  ' critical reactions at the;
    Ni = Ag * Ni + Au * Hg  '       core - mantle boundary
    Line -( Fe, Ni ), Si    ' plot statistical core trendline
    Hg = Fe                 ' temperature of blood
Next i

Sleep

[dodicat]

Code: Select all

Type pt
    As Single x,y,z
End Type

Type angle
    As Single a(1 To 6)
    Declare Sub set(p As pt)
End Type

Sub angle.set(p As pt) 
    This= Type<angle>({Sin(p.x),Sin(p.y),Sin(p.z),Cos(p.x),Cos(p.y),Cos(p.z)}) 
End Sub

Type PaperStar
    As pt p(Any)
    As angle a
    As pt ctr
    As Ulong col
    As pt da
    As pt b
    Declare Constructor
    Declare Constructor(As Long,As Long,As Long,As Single,As pt,As Ulong,num As Long)
    Declare Sub fill(im As Any Ptr=0,zval As Single=0)
    Declare Function rotate() As PaperStar
End Type


#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro  
        
        #define range(f,l) Rnd*((l)-(f))+(f)
        #define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        #define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
        
        Function Rotate(c As pt,p As pt,a As angle,scale As pt=Type<pt>(1,1,1)) As pt
            Dim As Single dx=p.x-c.x,dy=p.y-c.y,dz=p.z-c.z
            Return Type<pt>((scale.x)*((a.a(5)*a.a(6))*dx+(-a.a(4)*a.a(3)+a.a(1)*a.a(2)*a.a(6))*dy+(a.a(1)*a.a(3)+a.a(4)*a.a(2)*a.a(6))*dz)+c.x,_
            (scale.y)*((a.a(5)*a.a(3))*dx+(a.a(4)*a.a(6)+a.a(1)*a.a(2)*a.a(3))*dy+(-a.a(1)*a.a(6)+a.a(4)*a.a(2)*a.a(3))*dz)+c.y,_
            (scale.z)*((-a.a(2))*dx+(a.a(1)*a.a(5))*dy+(a.a(4)*a.a(5))*dz)+c.z)',p.col)
        End Function
        
        Function perspective(p As pt,eyepoint As pt) As pt
            Dim As Single   w=1+(p.z/eyepoint.z)
            Return Type<pt>((p.x-eyepoint.x)/w+eyepoint.x,_
            (p.y-eyepoint.y)/w+eyepoint.y,_
            (p.z-eyepoint.z)/w+eyepoint.z)',p.col)
        End Function 
        
        Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
            Static As Double timervalue,_lastsleeptime,t3,frames
            Var t=Timer
            frames+=1
            If (t-t3)>=1 Then t3=t:fps=frames:frames=0
            Var sleeptime=_lastsleeptime+((1/myfps)-T+timervalue)*1000
            If sleeptime<1 Then sleeptime=1
            _lastsleeptime=sleeptime
            timervalue=T
            Return sleeptime
        End Function
        
        Sub star(starX As Single,starY As Single,size As Single,num As Long=5,cut As Single=.4,s() As pt)
            Redim s(2*num)
            Var count=0,rad=0.0,_px=0.0,_py=0.0,pi=4*Atn(1)
            Var rot=0
            For z As Single=0+.28 +rot To 2*pi+.1+.28 +rot Step 2*pi/(2*num)
                count=count+1
                If count Mod 2=0 Then rad=size Else rad=cut*size
                _px=starx+rad*Cos(z)
                _py=stary+rad*Sin(z)
                s(count-1).x=_px
                s(count-1).y=_py
            Next z
        End Sub
        
        Function getctr(s As PaperStar) As pt
            Dim As Single cx,cy,cz
            Dim As Long sz=Ubound(s.p)+1
            For n As Long=Lbound(s.p) To Ubound(s.p)
                cx+=s.p(n).x
                cy+=s.p(n).y
                cz+=s.p(n).z
            Next
            Return Type(cx/sz,cy/sz,cz/sz)
        End Function
        
        
        Constructor PaperStar
        End Constructor
        
        Constructor PaperStar(x As Long,y As Long,z As Long,sz As Single,a As pt,colour As Ulong,n As Long)
        star(x,y,sz,n,range(.2,.6),p())
        
        For n As Long=Lbound(p) To Ubound(p)
            p(n).z=z
        Next
        da=a
        col=colour
        End Constructor
        
        Sub PaperStar.fill(im As Any Ptr=0,zval As Single=0)
            #define ub Ubound
            Static As Ubyte r,g,b
            r=Cast(Ubyte Ptr,@col)[2]
            g=Cast(Ubyte Ptr,@col)[1]
            b=Cast(Ubyte Ptr,@col)[0]
            Dim As Long Sy=1e6,By=-1e6,i,j,y,k
            Dim As Single a(Ub(p)+1,1),dx,dy
            For i =0 To Ub(p)
                a(i,0)=p(i).x
                a(i,1)=p(i).y
                If Sy>p(i).y Then Sy=p(i).y
                If By<p(i).y Then By=p(i).y
            Next i
            Dim As Single xi(Ub(a,1)),S(Ub(a,1))
            a(Ub(a,1),0) = a(0,0)
            a(Ub(a,1),1) = a(0,1)
            For i=0 To Ub(a,1)-1
                dy=a(i+1,1)-a(i,1)
                dx=a(i+1,0)-a(i,0)
                If dy=0 Then S(i)=1
                If dx=0 Then S(i)=0
                If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
            Next i
            For y=Sy-1 To By+1
                k=0
                For i=0 To Ub(a,1)-1
                    If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
                    (a(i,1)>y Andalso a(i+1,1)<=y) Then
                    xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
                    k+=1
                End If
            Next i
            For j=0 To k-2
                For i=0 To k-2
                    If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
                Next i
            Next j
            For i = 0 To k - 2 Step 2
                Line im,(xi(i),y)-(xi(i+1)+1,y),Rgb(zval*r,zval*g,zval*b)
            Next i
        Next y
    End Sub
    
    Function PaperStar.rotate() As PaperStar
        b.x+=da.x
        b.y+=da.y
        b.z+=da.z 
        a.set(b)
        Dim As PaperStar s=This
        ctr= getctr(s)
        For n As Long=Lbound(p) To Ubound(p)
            s.p(n)= ..Rotate(ctr,this.p(n),a)
            s.p(n)= perspective(s.p(n),Type(512,768\2,1500))
        Next
        Return s
    End Function
    
    #define rcolour Rgb(100+Rnd*155,100+Rnd*155,100+Rnd*155)
    Const back=Rgb(0,0,0)
    Const f=0.03
    Dim Shared As Integer xres,yres,mx,my
    #macro setP(z)
    p(0)=z
    p(1)=Point(x,y-1,i)
    p(2)=Point(x+1,y,i)
    p(3)=Point(x,y+1,i)
    p(4)=Point(x-1,y,i)
    #endmacro
    
    #macro setC
    r+=Cast(Ubyte Ptr,@p(n))[2]
    g+=Cast(Ubyte Ptr,@p(n))[1]
    b+=Cast(Ubyte Ptr,@p(n))[0]
    a+=Cast(Ubyte Ptr,@p(n))[3]
    #endmacro
    
    Sub inc(i As Long,Byref col As Ulong)
        Static As Long k=1
        Var r=Cast(Ubyte Ptr,@col)[2]
        Var g=Cast(Ubyte Ptr,@col)[1]
        Var b=Cast(Ubyte Ptr,@col)[0]
        Var a=Cast(Ubyte Ptr,@col)[3]
        Select Case i
        Case 0
            If r>255 Or r<0 Then k=-k
            r+=k
            col= Rgba(r,g,b,a)   
        Case 1
            If g>255 Or g<0 Then k=-k
            g+=k
            col= Rgba(r,g,b,a)
        Case 2
            If b>255 Or b<0 Then k=-k
            b+=k
            col= Rgba(r,g,b,a)
        Case 3
            If a>255 Or a<0 Then k=-k
            a+=k
            col= Rgba(r,g,b,a)   
        End Select
    End Sub
    
    Sub merge(Byref c As Ulong,x As Long,y As Long,i As Any Ptr)
        Static As Long p(0 To 4)
        Var r=0,g=0,b=0,a=0,z=0
        setP(c)
        For n As Long=0 To 4
            If p(n)<>back Then
                setC
                z+=1
            End If
        Next
        If z Then c=Rgba(r\z,g\z,b\z,a\z)
    End Sub
    
    Sub filter(i As Any Ptr,n As Long)
        Dim As Integer ix,iy
        Imageinfo i,ix,iy
        Dim As Long p(0 To 4)
        Dim As Long k,x,y,r,g,b,a
        For k =1 To n
            For x =1 To ix-2
                For y =1 To iy-2
                    r=0:g=0:b=0:a=0
                    setP(Point(x,y,i))
                    For n As Long=0 To 4
                        setC
                    Next
                    Pset i,(x,y),Rgba(r\5,g\5,b\5,a\5)
                    
                Next y
            Next x
        Next k
    End Sub
    
    Sub nebula(c As Ulong,x As Long,y As Long,lim As Long,i As Any Ptr)
        #define Intrange(f,l) Int(Rnd*((l+1)-(f)))+(f)
        #define offscreenx(n) n<10 Or n> (xres -10 )
        #define offscreeny(n) n<10 Or n> (yres -10)
        #macro increment
        Select Case k
        Case 1:inc(0,c)
        Case 2:inc(1,c)
        Case 3:inc(2,c)
        Case 4:inc(3,c)
        End Select
        count+=1
        #endmacro
        
        Dim As Long count
        Do
            Var k=intrange(1,4)
            Select Case k
            Case 1
                Var k=intrange(1,4)
                increment
                If offscreeny((y-1))Then y=intrange(10,760)
                If Rnd<f Then  merge(c,x,y-1,i)
                Pset i,(x,y-1),c
                y=y-1
            Case 2 
                Var k=intrange(1,4) 
                increment
                If offscreenx((x+1)) Then x=intrange(10,1000)
                If Rnd<f Then merge(c,x+1,y,i)
                Pset i,(x+1,y),c
                x=x+1
            Case 3 
                Var k=intrange(1,4)
                increment
                If offscreeny((y+1)) Then y=intrange(10,760)
                If Rnd<f Then  merge(c,x,y+1,i)
                Pset i,(x,y+1),c
                y=y+1
            Case 4 
                Var k=intrange(1,4)
                increment
                If offscreenx((x-1)) Then x=intrange(10,1000)
                If Rnd<f Then  merge(c,x-1,y,i)
                Pset i,(x-1,y),c
                x=x-1
            End Select
        Loop Until count > lim
    End Sub
    '  end nebula
    Dim As String zz = _
    "C4294967295BM209,585M+91,-252M+58,255"_
    &"BM+-109,-106M+84,1"_
    &"BM+95,-144"_
    &"M+-9,247M+80,3"_
    &"BM+91,-239"_
    &"BM+-9,7M+-7,238"_
    &"BM+13,-238M+35,0M+36,14M+24,31M+6,34"_
    &"M+-9,29M+-19,5M+-18,4M+-33,2M+-22,0M+-3,-1"_
    &"M+-7,-1"_
    &"BM+56,2M+30,29M+14,42M+-6,22M+-13,11"_
    &"M+-20,10M+-23,3M+-21,1M+-22,-1"_
    &"BM+179,-235M+6,234"_
    &""_
    &"BM+93,-234M+-101,2"_
    &"BM+53,100M+-49,-1"_
    &"BM+82,136M+-77,-3"_
    &""_
    &"BM+155,-241M+2,245"_
    &"BM+3,-245M+53,7M+28,53M+8,45"_
    &"M+-16,7M+-27,12M+-28,3M+-20,-1M+64,110"_
    &"BM+104,-236"_
    &"M+111,0"_
    &"BM+-51,0M+1,245"
    
    Randomize 4
    Screeninfo xres,yres
    Screenres .9*xres,.9*yres,32,,64
    Width .9*xres\8,.9*yres\16
    Screeninfo xres,yres
    Dim As Any Ptr i
    i=Imagecreate(xres,yres,back)
    Draw i,zz
    Dim As Ulong c=Rgba(100,100,100,10)
    Locate 20,20
    Print "please wait . . ."
    nebula(c,xres\2,yres\2,3000000,i)
    filter(i,4)
 
    
    Dim As PaperStar s(1 To 2500)
    For n As Long=1 To Ubound(s)
        Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
        s(n)=PaperStar(range(-1000,(xres+1000)),range(-1000,(yres+1000)),Rnd*3000*2,10,tmp,rcolour,irange(3,9))
    Next
    
    SetQsort(PaperStar,QsortZ,down,.ctr.z)
    
    Dim As PaperStar z(1 To Ubound(s))
    Dim As Long fps
    Dim As Single fn
    
    #define onscreen(Q) Q.ctr.x>0 And Q.ctr.x<xres And Q.ctr.y>0 And Q.ctr.y<yres
    Dim As Long min=1000000,max=-1000000,k=1,__,flag,btn
    Do
        Getmouse __,__,__,btn
        Screenlock
        Cls
        Put(0,0),i,Alpha,150
        For n As Long=1 To Ubound(s)
            For m As Long=Lbound (s(n).p) To Ubound (s(n).p)
                s(n).p(m).z= s(n).p(m).z-15*k
            Next m
            z(n)=s(n).rotate
            If min>z(n).ctr.z Then min=z(n).ctr.z
            If max<z(n).ctr.z Then max=z(n).ctr.z
            
            If btn=1 And flag=0 Then k=-k:flag=1
            If k=1 Then
                If s(n).ctr.z<-1440 Or  onscreen(s(n))=0 Then
                    Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                    s(n)=PaperStar(range(-1000,(xres+1000)),range(-1000,(yres+1000)),3000+Rnd*(3000),10,tmp,rcolour,irange(3,9))
                End If
            Else
                If s(n).ctr.z>3000  Or  onscreen(s(n))=0 Then
                    Dim As pt tmp=Type((Rnd-Rnd)/20,(Rnd-Rnd)/20,(Rnd-Rnd)/20)
                    s(n)=PaperStar(range(-1000,(xres+1000)),range(-1000,(yres+1000)),-1300-Rnd*(100),10,tmp,rcolour,irange(3,9))
                End If
            End If
            
        Next n
        flag=btn
        QsortZ(z(),1,Ubound(z))
        
        For n As Long=1 To Ubound(z)
            If onscreen(z(n)) Then
                fn=map(min,max,z(n).ctr.z,1,.2)
                z(n).fill(,fn)
            End If
        Next n
        Draw String(10,10), "fps " &fps
        Screenunlock
        Sleep regulate(60,fps)
    Loop Until Inkey=Chr(27)
    
    Sleep
    Imagedestroy i
    
    
     

Richard.
I have sent our mutual friend an email to see what's up, nearly six weeks without a post is unusual.
I know he had some underwater thing posted, which I can no longer find.

[Richard]

Your graphics says it all. On Oct 20, 2020, Albert was banned for off topic posting, until 31 Dec 2020.
The admins tired of all the reports they had to handle regarding Albert's posts unrelated to FB.
He now has time to find a more appropriate forum. Or if he returns, to change his approach.

[dodicat]

Thanks Richard, he answered my email and at least he is OK.
I missed the episode of his ban.
I hope he gets back before that date. Seems silly closing down squares and thus exposing squares coders in the open forum.
We are very vulnerable there, maybe pentacles will be a new roost. But we are also getting thin on the ground, has silly coding gone out of fashion?
Thanks again.

[Richard]

I wrote some code that converted a pen plotter character set to FB graphics Draw.
I thought it might be useful to some. Comments welcome.

Code: Select all

' draw ascii text onto a graphics page
Sub DrawString( Byref ascii As String )
    Static As String*120 s( 32 To 127 ) = { _
    "BM+6,0", _
    "M+0,-1 BM+0,-1 M+0,-4 BM+2,6", _
    "BM+0,-4 M+0,-2 BM+1,2 M+0,-2 BM+2,6", _
    "BM+1,0 M+0,-6 BM+2,6 M+0,-6 BM-3,4 M+4,0 BM-4,-2 M+4,0 BM+2,4", _
    "BM+0,-1 M+3,0 M+1,-1 M-1,-1 M-2,0 M-1,-1 M+1,-1 M+3,0 BM-2,5 M+0,-6 BM+4,6", _
    "M+0,-1 M+4,-4 M+0,-1 BM-4,0 M+1,0 M+0,1 M-1,0 M+0,-1 BM+3,6 M+0,-1 M+1,0 M+0,1 M-1,0 BM+3,0", _
    "BM+4,0 M-4,-4 M+0,-1 M+1,-1 M+1,1 M+0,1 M-2,2 M+0,1 M+1,1 M+1,0 M+2,-2 BM+2,2", _
    "BM+0,-4 M+0,-2 BM+2,6", _
    "BM+2,0 M-2,-2 M+0,-2 M+2,-2 BM+2,6", _
    "M+2,-2 M+0,-2 M-2,-2 BM+4,6", _
    "BM+0,-1 M+4,-4 BM-4,0 M+4,4 BM-2,0 M+0,-4 BM-2,2 M+4,0 BM+2,3", _
    "BM+2,-1 M+0,-4 BM-2,2 M+4,0 BM+2,3", _
    "BM-1,1 M+1,-1 M+0,-1 BM+2,1", _
    "BM+0,-3 M+4,0 BM+2,3", _
    "M+0,-1 BM+2,1", _
    "M+0,-1 M+4,-4 M+0,-1 BM+2,6", _
    "BM+1,0 M-1,-1 M+0,-4 M+1,-1 M+2,0 M+1,1 M+0,4 M-1,1 M-2,0 BM+5,0", _
    "BM+0,-5 M+1,-1 M+0,6 BM-1,0 M+2,0 BM+2,0", _
    "BM+4,0 M-4,0 M+0,-2 M+1,-1 M+2,0 M+1,-1 M+0,-1 M-1,-1 M-2,0 M-1,1 BM+6,5", _
    "BM+0,-1 M+1,1 M+2,0 M+1,-1 M+0,-1 M-1,-1 M+1,-1 M+0,-1 M-1,-1 M-2,0 M-1,1 BM+2,2 M+1,0 BM+3,3", _
    "BM+3,0 M+0,-6 M-3,3 M+0,1 M+4,0 BM+2,2", _
    "BM+0,-1 M+1,1 M+2,0 M+1,-1 M+0,-2 M-1,-1 M-3,0 M+0,-2 M+4,0 BM+2,6", _
    "BM+0,-3 M+3,0 M+1,1 M+0,1 M-1,1 M-2,0 M-1,-1 M+0,-3 M+2,-2 M+1,0 BM+3,6", _
    "M+0,-1 M+4,-4 M+0,-1 M-4,0 BM+6,6", _
    "BM+1,0 M-1,-1 M+0,-1 M+1,-1 M-1,-1 M+0,-1 M+1,-1 M+2,0 M+1,1 M+0,1 M-1,1 M+1,1 M+0,1 M-1,1 M-2,0 BM+0,-3 M+2,0 BM+3,3", _
    "BM+1,0 M+1,0 M+2,-2 M+0,-3 M-1,-1 M-2,0 M-1,1 M+0,1 M+1,1 M+3,0 BM+2,3", _
    "BM+0,-1 M+0,-1 BM+0,-1 M+0,-1 BM+2,4", _
    "BM-1,1 M+1,-1 M+0,-2 BM+0,-1 M+0,-1 BM+2,4", _
    "BM+2,0 M-3,-3 M+3,-3 BM+2,6", _
    "BM+0,-2 M+4,0 BM-4,-2 M+4,0 BM+2,4", _
    "M+3,-3 M-3,-3 BM+5,6", _
    "BM+2,0 M+0,-1 BM+0,-1 M+0,-1 M+1,-1 M+0,-1 M-1,-1 M-1,0 M-1,1 BM+5,5", _
    "BM+2,-1 M+0,-1 M-1,-1 M-1,1 M+0,1 M+1,1 M+2,0 M+1,-1 M+0,-4 M-1,-1 M-2,0 M-1,1 BM+6,5", _
    "M+0,-2 M+2,-4 M+2,4 M+0,2 BM-4,-2 M+4,0 BM+2,2", _
    "M+3,0 M+1,-1 M+0,-1 M-1,-1 M+1,-1 M+0,-1 M-1,-1 M-3,0 BM+1,6 M+0,-6 BM+0,3 M+2,0 BM+3,3", _
    "BM+4,-1 M-1,1 M-2,0 M-1,-1 M+0,-4 M+1,-1 M+2,0 M+1,1 BM+2,5", _
    "M+3,0 M+1,-1 M+0,-4 M-1,-1 M-3,0 BM+1,6 M+0,-6 BM+5,6", _
    "BM+4,0 M-4,0 M+0,-6 M+4,0 BM-4,3 M+2,0 BM+4,3", _
    "M+0,-6 M+4,0 BM-4,3 M+2,0 BM+4,3", _
    "BM+3,-3 M+1,0 M+0,3 M-3,0 M-1,-1 M+0,-4 M+1,-1 M+3,0 BM+2,6", _
    "M+0,-6 BM+4,6 M+0,-6 BM-4,3 M+4,0 BM+2,3", _
    "M+2,0 BM-2,-6 M+2,0 BM-1,6 M+0,-6 BM+3,6", _
    "BM+0,-1 M+1,1 M+2,0 M+1,-1 M+0,-5 BM+2,6", _
    "M+0,-6 BM+0,3 M+1,0 BM+3,3 M-3,-3 M+3,-3 BM+2,6", _
    "BM+4,0 M-4,0 M+0,-6 BM+6,6", _
    "M+0,-6 M+2,4 M+2,-4 M+0,6 BM+2,0", _
    "M+0,-6 M+4,4 BM+0,2 M+0,-6 BM+2,6", _
    "M+0,-6 M+4,0 M+0,6 M-4,0 BM+6,0", _
    "M+0,-6 M+3,0 M+1,1 M+0,1 M-1,1 M-3,0 BM+6,3", _
    "BM+4,0 M-2,-2 BM+2,0 M-2,2 M-1,0 M-1,-1 M+0,-4 M+1,-1 M+2,0 M+1,1 M+0,3 BM+2,2", _
    "M+0,-6 M+3,0 M+1,1 M+0,1 M-1,1 M-3,0 BM+1,0 M+3,3 BM+2,0", _
    "BM+0,-1 M+1,1 M+2,0 M+1,-1 M-4,-4 M+1,-1 M+2,0 M+1,1 BM+2,5", _
    "BM+2,0 M+0,-6 BM-2,0 M+4,0 BM+2,6", _
    "BM+0,-6 M+0,5 M+1,1 M+2,0 M+1,-1 M+0,-5 BM+2,6", _
    "BM+0,-6 M+3,6 M+3,-6 BM+2,6", _
    "BM+0,-6 M+0,5 M+1,1 M+2,-2 M+2,2 M+1,-1 M+0,-5 BM-3,4 M+0,-1 BM+5,3", _
    "M+0,-1 M+4,-4 M+0,-1 BM+0,6 M+0,-1 M-4,-4 M+0,-1 BM+6,6", _
    "BM+2,0 M+0,-3 BM-2,-3 M+0,1 M+2,2 M+2,-2 M+0,-1 BM+2,6", _
    "BM+4,0 M-4,0 M+0,-1 M+4,-4 M+0,-1 M-4,0 BM+6,6", _
    "BM+2,0 M-2,0 M+0,-6 M+2,0 BM+2,6", _
    "BM+0,-6 M+0,1 M+4,4 M+0,1 BM+2,0", _
    "M+2,0 M+0,-6 M-2,0 BM+4,6", _
    "BM+0,-4 M+2,-2 M+2,2 BM-2,-2 M+0,6 BM+4,0", _
    "BM+0,1 M+4,0 BM+2,-1", _
    "BM+0,-6 M+2,2 BM+2,4", _
    "BM+3,-1 M-1,1 M-1,0 M-1,-1 M+0,-2 M+1,-1 M+1,0 M+1,1 M+0,2 M+1,1 BM+2,0", _
    "M+0,-6 BM+0,4 M+2,2 M+1,0 M+1,-1 M+0,-2 M-1,-1 M-1,0 M-2,2 BM+6,2", _
    "BM+4,0 M-3,0 M-1,-1 M+0,-2 M+1,-1 M+3,0 BM+2,4", _
    "BM+4,0 M+0,-6 BM+0,4 M-2,2 M-1,0 M-1,-1 M+0,-2 M+1,-1 M+1,0 M+2,2 BM+2,2", _
    "BM+3,0 M-2,0 M-1,-1 M+0,-2 M+1,-1 M+2,0 M+1,1 M-1,1 M-3,0 BM+6,2", _
    "BM+1,0 M+0,-5 M+1,-1 M+1,0 M+1,1 BM-4,2 M+3,0 BM+3,3", _
    "BM+0,1 M+1,1 M+2,0 M+1,-1 M+0,-4 M-1,-1 M-2,0 M-1,1 M+0,2 M+1,1 M+3,0 BM+2,0", _
    "M+0,-6 BM+0,4 M+2,-2 M+1,0 M+1,1 M+0,3 BM+2,0", _
    "M+0,-3 BM+0,-1 M+0,-1 BM+2,5", _
    "BM+0,1 M+1,1 M+1,0 M+1,-1 M+0,-4 BM+0,-1 M+0,-1 BM+2,5", _
    "M+0,-6 BM+0,4 M+2,0 BM+2,2 M-2,-2 M+2,-2 BM+2,4", _
    "BM+1,0 M-1,-1 M+0,-5 BM+3,6", _
    "M+0,-4 BM+0,1 M+1,-1 M+1,1 M+1,-1 M+1,1 M+0,3 BM-2,-2 M+0,-1 BM+4,3", _
    "M+0,-4 BM+0,1 M+1,-1 M+1,0 M+1,1 M+0,3 BM+2,0", _
    "BM+1,0 M-1,-1 M+0,-2 M+1,-1 M+2,0 M+1,1 M+0,2 M-1,1 M-2,0 BM+5,0", _
    "BM+0,2 M+0,-6 BM+0,4 M+3,0 M+1,-1 M+0,-2 M-1,-1 M-2,0 M-1,1 BM+6,3", _
    "BM+4,2 M+0,-6 BM+0,4 M-3,0 M-1,-1 M+0,-2 M+1,-1 M+2,0 M+1,1 BM+2,3", _
    "M+0,-4 BM+0,2 M+2,-2 M+1,0 M+1,1 BM+2,3", _
    "M+3,0 M+1,-1 M-1,-1 M-2,0 M-1,-1 M+1,-1 M+3,0 BM+2,4", _
    "BM+4,-1 M-1,1 M-1,-1 M+0,-5 BM-2,2 M+4,0 BM+2,4", _
    "BM+0,-4 M+0,3 M+1,1 M+1,0 M+2,-2 BM+0,2 M+0,-4 BM+2,4", _
    "BM+0,-4 M+2,4 M+2,-4 BM+2,4", _
    "BM+0,-4 M+0,3 M+1,1 M+1,-1 M+1,1 M+1,-1 M+0,-3 BM-2,3 M+0,-1 BM+4,2", _
    "M+4,-4 BM-4,0 M+4,4 BM+2,0", _
    "BM+0,-4 M+0,3 M+1,1 M+1,0 M+2,-2 BM-3,4 M+2,0 M+1,-1 M+0,-5 BM+2,4", _
    "BM+0,-4 M+4,0 M-4,4 M+4,0 BM+2,0", _
    "BM+2,0 M-1,-1 M+0,-1 M-1,-1 M+1,-1 M+0,-1 M+1,-1 BM+2,6", _
    "M+0,-6 BM+2,6", _
    "M+1,-1 M+0,-1 M+1,-1 M-1,-1 M+0,-1 M-1,-1 BM+4,6", _
    "BM+0,-2 M+1,-1 M+2,1 M+1,-1 BM+2,3", _
    "M+0,-6 M+4,0 M+0,6 M-4,0 M+4,-6 BM-4,0 M+4,6 BM-4,-3 M+4,0 BM-2,3 M+0,-6 BM+4,6" }
    
    Dim As Integer i, c
    For i = 0 To Len( ascii ) - 1
        c = ascii[ i ]
        If ( c < 32 ) Or ( c > 127) Then c = 127
        Draw s( c )
    Next i
    
End Sub

'===================================================================
Screen 21
Draw "C15"      ' colour
Draw "TA-25 "   ' rotate deg anticlk
Draw "S20 "     ' scale = size of the text

Draw "BM100,100"    ' start of the line
DrawString( "This is a demonstration." )

Draw "BM100,200"    ' start of the line
DrawString "abcdefghijklmnopqrstuvwxyz"

Draw "BM100,250"
DrawString "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Draw "BM100,300"
DrawString "+10.23456789e-6"

Draw "BM100,350"
DrawString "~`!@#$%^&*()_+|{}[]:;',./<>?"

DrawString Chr( 127 )

Draw "BM50,900"
Draw "TA0 "
Draw "S125 "
DrawString "ALBERT"

Draw "S8 "
DrawString "Small" 

'===================================================================
Sleep
'===================================================================

[jj2007]

I had never seen the Draw command - cute!

[BasicCoder2]

I had never seen the Draw command - cute!

"The DRAW statement combines most of the capabilities of the other graphics statements into an object definition language called Graphics Macro Language (GML). A GML command is a single character within a string, optionally followed by one or more arguments. The DRAW statement is valid only in graphics mode."

There was a long thread on the subject in which I worked on a tool for tracing images using the mouse which converted the tracing to DRAW strings as output.

viewtopic.php?f=8&t=22859

DRAW has limitations so I wrote my own version called DRAWIT to add things like line thickness..

Here is one of the examples. The bird image was traced by the generator tool to create data statements in the program below.

Code: Select all

screenres 640,480,32
color rgb(0,0,0),rgb(255,255,255):cls

Sub drawLine(x1 as integer,y1 as integer,x2 as integer, y2 as integer,size as integer,c as uinteger)
    Dim As Integer ax, ay, d, dx, dy, x, y
    circle (x1,y1),size,c,,,,f
    If x1 = x2 And y1 = y2 Then Exit Sub
 
    If x1 = x2 Then
        x = x1
        if y2>y1 then
            For y as integer  = y1 To y2
                circle (x,y),size,c,,,,f
            Next y
        else
            for y as integer = y2 to y1
                circle (x,y),size,c,,,,f
            next y
        end if
     
    Elseif y1 = y2 Then
        y = y1
        if x2>x1 then
            For x as integer = x1 To x2
                circle (x,y),size,c,,,,f
            next x
        else
            for x as integer = x2 to x1
                circle (x,y),size,c,,,,f
            next x
        end if

    Else
        dx = x2 - x1
        dy = y2 - y1
        ax = 1
        ay = 1
   
        If dx < 0 Then
            dx = -dx
            ax = -1
        End If
   
        If dy < 0 Then
            dy = -dy
            ay = -1
        End If
   
        x = x1
        y = y1
   
        dim as integer ii
   
        If dx >= dy Then
            ii = dx + 1
            dy Shl= 1
            d = dy - dx
            dx Shl= 1
     
            While ii > 0
                ii -= 1
                circle (x,y),size,c,,,,f
       
                If d >= 0 Then
                    y += ay
                    d -= dx
                 End If
       
                 d += dy
                 x += ax
              Wend
          Else
              ii = dy + 1
              dx Shl= 1
              d = dx - dy
              dy Shl= 1
              While ii > 0
                  ii -= 1
                  circle (x,y),size,c,,,,f
       
                  If d >= 0 Then
                      x += ax
                      d -= dy
                  End If
       
                  d += dx
                  y += ay
              Wend
          End If
    End If
End Sub

dim shared as integer cmdCount
read cmdCount
dim shared as string  cmd(cmdCount)
dim shared as integer px(cmdCount),py(cmdCount)

sub DrawIt()
    dim as integer prevX1,prevY1,penSize
    dim as uinteger color1,color2
    color1 = rgb(0,0,0)
    color2 = rgb(255,255,255)
   
    penSize = 1 'default
    'line canvas2,(0,0)-(640,480),rgb(255,0,255),bf  'clear canvas2
    prevX1 = 0
    prevY1 = 0
    if cmdCount<>0 then
        for i as integer = 0 to cmdCount-1
            if cmd(i)="M" then
                prevX1 = px(i)
                prevY1 = py(i)
            end if
            if cmd(i)="D" then
                'line canvas2,(prevX1,prevY1)-(px(i),py(i)),rgb(0,0,0)
                drawLine(prevX1,prevY1,px(i),py(i),penSize,rgb(0,0,0))
                prevX1 = px(i)
                prevY1 = py(i)
            end if
            if cmd(i)="P" then
                paint (px(i),py(i)),color2,rgb(0,0,0)
            end if
            if cmd(i)="L" then
                penSize = px(i)
            end if
            if cmd(i)="C" then
                color1 = px(i)
                color2 = py(i)
            end if
            sleep 10
        next i
    end if
end sub

'READ DATA FOR DRAWIT

for i as integer = 0 to cmdCount-1
    read cmd(i),px(i),py(i)
next i

DrawIt()

sleep

DATA 254
DATA "M",371,58,"D",409,60,"D",425,67,"D",431,70,"D",446,70,"D",464,70
DATA "D",472,71,"D",470,74,"D",454,79,"D",425,94,"D",414,105,"D",399,120
DATA "D",404,147,"D",405,175,"D",401,196,"D",388,228,"D",371,252,"D",350,270
DATA "D",330,287,"D",323,307,"D",316,322,"D",320,333,"D",326,342,"D",346,372
DATA "D",355,382,"D",363,380,"D",369,373,"D",375,369,"D",381,372,"D",374,376
DATA "D",368,383,"D",363,387,"D",359,387,"D",367,395,"D",375,396,"D",384,402
DATA "D",383,407,"D",375,401,"D",365,401,"D",357,396,"D",344,390,"D",335,395
DATA "D",328,400,"D",320,405,"D",308,419,"D",312,405,"D",324,395,"D",335,387
DATA "D",340,380,"D",334,366,"D",328,360,"D",303,321,"D",298,315,"D",302,311
DATA "D",314,295,"D",316,290,"D",308,302,"D",292,292,"D",286,297,"D",284,314
DATA "D",290,338,"D",298,354,"D",308,368,"D",321,371,"D",335,369,"D",336,373
DATA "D",319,377,"D",314,375,"D",322,380,"D",339,381,"D",336,385,"D",319,384
DATA "D",308,378,"D",304,380,"D",301,388,"D",298,395,"D",294,387,"D",298,381
DATA "D",300,373,"D",288,352,"D",280,337,"D",274,327,"D",267,303,"D",263,304
DATA "D",246,319,"D",228,336,"D",213,355,"D",201,369,"D",189,386,"D",178,399
DATA "D",171,405,"D",164,410,"D",160,407,"D",162,397,"D",171,374,"D",183,358
DATA "D",198,339,"D",214,313,"D",218,306,"D",210,305,"D",210,301,"D",224,289
DATA "D",227,284,"D",235,264,"D",238,249,"D",246,230,"D",260,209,"D",266,191
DATA "D",276,180,"D",286,167,"D",310,141,"D",331,123,"D",340,107,"D",348,86
DATA "D",358,69,"D",363,61,"D",372,58,"M",399,81,"D",403,78,"D",408,77
DATA "D",412,79,"D",415,82,"D",412,86,"D",408,89,"D",403,88,"D",400,85
DATA "D",399,81,"M",406,81,"D",403,83,"D",405,85,"D",408,85,"D",409,82
DATA "D",407,80,"D",406,83,"M",430,70,"D",429,77,"D",422,81,"D",422,88
DATA "D",425,93,"M",437,74,"D",441,75,"D",438,76,"M",425,87,"D",446,78
DATA "D",460,73,"D",471,72,"M",217,305,"D",256,288,"D",288,274,"D",318,247
DATA "D",344,243,"D",365,230,"D",390,210,"D",397,201,"M",259,288,"D",235,317
DATA "D",212,345,"D",188,379,"D",175,397,"D",165,401,"D",170,388,"D",180,366
DATA "D",199,335,"M",266,196,"D",266,205,"D",265,212,"D",267,217,"D",271,217
DATA "D",279,219,"D",286,218,"D",294,226,"D",297,232,"D",304,233,"D",306,240
DATA "D",316,244,"D",325,245,"M",294,226,"D",284,235,"D",274,241,"D",267,246
DATA "D",257,249,"D",251,250,"D",250,239,"D",250,223,"M",297,231,"D",286,242
DATA "D",274,249,"D",264,253,"D",248,255,"D",244,251,"D",242,233,"M",305,239
DATA "D",272,260,"D",238,281,"D",231,271,"M",308,242,"D",282,261,"D",255,278
DATA "D",241,286,"D",234,288,"D",229,281,"M",403,170,"D",390,191,"D",381,201
DATA "D",369,205,"D",358,204,"D",348,209,"D",335,209,"D",331,205,"D",320,196
DATA "D",296,191,"D",288,184,"D",287,166,"M",398,116,"D",382,115,"D",364,104
DATA "D",364,86,"D",374,75,"D",385,68,"D",404,64,"D",419,63,"M",302,314
DATA "D",314,321,"M",270,312,"D",284,311,"C",-16777216,-4148863,"M",398,115,"D",404,115
DATA "C",-16777216,-1449553,"P",382,80,"C",-16777216,0,"P",446,71,"C",-16777216,-2441326,"P",434,76
DATA "C",-16777216,-1715819,"P",381,158,"C",-16777216,-5004419,"P",316,209,"C",-16777216,-8885929,"P",264,228
DATA "C",-16777216,-5133968,"P",281,239,"C",-16777216,-8821152,"P",247,262,"C",-16777216,-10531523,"P",290,262
DATA "C",-16777216,-4741762,"P",334,260,"C",-16777216,-8230809,"P",207,331,"C",-16777216,-5472933,"P",346,380
DATA "C",-16777216,11304283,"P",293,351

[srvaldez]

@BasicCoder2
very nice drawing :-)
could you post your latest tracer code ?

[angros47]

I missed the episode of his ban.

You missed it because the post was removed. He had basically opened a new topic, always on the same subject, directed to the admins, claiming to have found another compression formula, and needing "only" to write a decompressor. Despite the admins had clearly told him not to do that, since he had clogged the forum for years with thousands of similar posts. He was banned after that, the post was left for some days for him to be able to read it, and then removed.

[integer]

@BasicCoder2
very nice drawing :-)
could you post your latest tracer code ?

@BasicCoder2
Was your generator tool used to draw an outline of the FreeBasic icon horse?

I would like to see the code or an explanation of how the algorithm incremented to the next pixel, especially tracing curves of degree 3 and larger

Your removal of artifacts is impressive!

[dodicat]

Basiccoder's bird again.

Code: Select all

Dim as string b = _
"C0s3BM250,30M+-12,-3M+-11,0M+-21,-1M+-16,15M+-20,40"_
&"M+-15,19M+-28,25M+-13,18M+-17,20M+-2,11M+-10,17"_
&"M+-7,11M+-7,13M+-4,21M+-6,16M+-8,8M+-9,7"_
&"M+-2,6M+7,2M+-16,28M+-17,24M+-12,17M+-8,28"_
&"M+3,5M+19,-18M+47,-56M+34,-31M+9,21M+13,25"_
&"M+13,23M+-6,13M+3,9M+9,-16M+12,4M+17,1"_
&"M+2,-4M+-12,0M+-6,0M+-5,-4M+21,-4M+-3,-4"_
&"M+-11,3M+-12,-4M+-11,-14M+-10,-20M+-5,-18M+2,-11"_
&"M+4,-9M+5,-2M+12,6M+1,3M+8,-10M+-6,10"_
&"M+-9,14M+10,18M+19,28M+5,4M+6,9M+-2,8"_
&"M+-7,7M+-7,5M+-11,10M+-4,6M+-2,9M+10,-11"_
&"M+9,-7M+11,-8M+9,-4M+18,12M+7,-2M+10,6"_
&"M+2,-3M+-6,-5M+-10,-4M+-7,-7M+8,-5M+3,-5"_
&"M+8,-4M+-5,-4M+-8,6M+-5,5M+-7,2M+-15,-22"_
&"M+-14,-17M+-9,-17M+9,-20M+6,-17M+24,-21M+17,-16"_
&"M+18,-24M+12,-34M+3,-16M+0,-21M+-1,-19M+-3,-18"_
&"M+22,-25M+36,-17M+8,0M+4,-6M+-6,-3M+-35,1"_
&"M+-4,-2M+-10,-7M+-34,-4M+-6,1M+53,13M+-3,8"_
&"M+-4,3M+0,7M+37,-17M+9,-3"_
&"BM+-35,9P4294925568,0"_
&"BM+-10,9M+4,8"_
&"BM+2,-6P4294309365,0"_
&"BM+-11,-27M+-21,3"_
&"M+-15,4M+-8,6M+-11,12M+0,9M+1,7M+6,4"_
&"M+9,6M+9,1M+6,0M+12,2"_
&"BM+-14,-26P4294920192,0"_
&"BM+9,-10"_
&"M+-3,4M+2,2M+5,4M+5,-1M+3,-3M+0,-4"_
&"M+0,-1M+-7,-2"_
&"M+-5,0"_
&"BM+5,4P4294309365,0"_
&"BM+-1,0M+2,1M+0,1M+-4,0"_
&"M+5,-2M+-3,1"_
&"BM+0,85M+-9,10M+-11,17M+-8,5"_
&"M+-7,2M+-7,1M+-4,-2M+-3,3M+-7,3M+-13,1"_
&"M+-7,-5M+-5,-5M+-3,-2M+-9,-3M+-11,-1M+-8,-3"_
&"M+-2,-3M+-2,-2M+-5,-17"_
&"BM+64,-13P4294949376,0"_
&"BM+-83,35M+2,15"_
&"M+0,9M+6,4M+6,0M+5,-2M+8,8M+6,8"_
&"M+5,0M+4,8M+8,3M+14,2M+19,-5M+21,-14"_
&"M+17,-14M+8,-7M+5,-4"_
&"BM+-89,15P4294904320,0"_
&"BM+-61,7M+2,24"_
&"M+5,1M+15,-5M+13,-9M+11,-7"_
&"BM+-31,1"_
&"BM+9,-4"_
&"P4288287744,0"_
&"BM+-30,7M+3,19M+2,5M+5,0M+9,-2M+10,-4"_
&"M+7,-3M+9,-7M+4,-5M+4,-4"_
&"BM+-49,18P4278255381,0"_
&"BM+-16,24"_
&"M+7,8M+22,-12M+18,-10M+15,-9M+15,-10"_
&"BM+1,1"_
&"M+-10,8M+-15,10M+-18,12M+-16,11M+-10,5M+-5,1"_
&"M+-7,-9"_
&"BM+8,6P4294967295,0"_
&"BM+9,-20P4283378688,0"_
&"BM+77,-21M+-5,6M+-20,17"_
&"M+-10,8M+-18,9M+-28,10M+-20,9M+-6,3"_
&"BM+60,-33"_
&"P4280944128,0"_
&"BM+-18,15M+-12,16M+-19,23M+-16,21M+-19,28M+-13,17"_
&"M+-6,7M+-6,0M+10,-25M+6,-15"_
&"BM+32,-35P4294930944,0"_
&"BM+-48,75"_
&"M+-6,6"_
&"BM+10,-22P4294309365,0"_
&"BM+99,-71M+16,-1"_
&"BM+-1,24"_
&"BM+7,15"_
&"P4287401472,0"_
&"BM+25,-26M+-16,-12"_
&"BM+28,42P4287401472,0"_
&"BM+-12,-88P4294965248,0"_
&"BM+85,-206P4294967295,0"_
&"BM+15,4"_
&"P4294901760,0"_
&"BM+-33,-6M+4,-1M+2,1M+-8,0"

Screenres 400, 300, 32
color ,rgb(0,0,50)
cls
Draw b
Sleep
 

Richard.
Do you use an editor to draw the fonts, it must have been a lot of work.
They would be very handy for games coders.

[srvaldez]

@dodicat
that's instant bird, I kind of like the slow drawing of BasicCoder2's code, the only thing missing is the hand with pen, that would be cool :-)

[BasicCoder2]

@BasicCoder2
very nice drawing :-)
could you post your latest tracer code ?

It was traced from a photo and the colors were picked from the photo using the pick color tool of the tracer program.

There is no "latest" code as I did a few versions. I will try and find a suitable one and post in another thread. There are two versions, one generates data for the DRAW statement and another one generates data for my DRAWIT function. We are really talking about vector graphics here.

[BasicCoder2]

@BasicCoder2 Was your generator tool used to draw an outline of the FreeBasic icon horse?

No. That was done using an automatic routine that traces around a blob (area of same color).

I would like to see the code or an explanation of how the algorithm incremented to the next pixel, especially tracing curves of degree 3 and larger

traceSilouette.bas

Code: Select all

chdir exepath()
' needed to load .png image
#include once "FBImage.bi"  
'THIS ASSUMES A 480x480 image.
screenres 480,480,32

dim shared as any ptr image1,image2
image1 = imagecreate(480,480) 'blob image with black background
image2 = imagecreate(480,480) 'save image of blob's outline


dim shared as integer xp(10000)  'save contour coordinates
dim shared as integer yp(10000)
dim shared as integer count      'count number of coordinates

sub TraverseBlob(x as integer, y as integer,image2 as any ptr,c as uinteger,image as any ptr)
    
    dim as integer ox,oy,sx,sy,direction,cc

    direction = 0
    ox = x
    oy = y
    sx = x
    sy = y
    cc = point(x,y,image)  'color to draw outline
    xp(count)=x
    yp(count)=y
    count = count + 1
    
    do
 
        select case as const direction

        'EAST
        case 0
        if point(x+1,y-1,image) = c then
            direction = 3 'north
        else
            if point(x+1,y,image) <> c then
                direction = 1 'south
            end if
        end if
        x = x + 1
  
        'SOUTH  
        case 1
        if point(x,y+1,image) = c then
            direction = 0 'east
        else
            if point(x-1,y+1,image) <> c then
                direction = 2 'west
            end if
        end if
        y = y + 1

        'WEST
        case 2
        if point(x-2,y,image) = c then
            direction = 1 'south
        else
            if point(x-2,y-1,image) <> c then
                direction = 3 'north
            end if
        end if
        x = x - 1

        'NORTH
        case 3
            if point(x-1,y-2,image) = c then
                direction = 2 'west
            else
                if point(x,y-2,image) <> c then
                    direction = 0 'east
            end if
        end if
        y = y - 1
        end select

        pset image2,(x,y),rgb(255,255,255)  '
        
        xp(count)=x
        yp(count)=y
        count = count + 1
        
        ox = x
        oy = y

        
    loop until sx = x and sy = y
    
end sub


'replace with this with your own 480x480 image
image1 = LoadRGBAFile("fbHorse.png")
'bload "fbHorse.bmp",image1   'if your image is a bmp format

put (0,0),image1
print
print " TAP SPACE BAR"
sleep

dim as integer blobFound = 0
'scans image array to find blob
for j as integer = 1 to 479
    for i as integer = 1 to 479
        if blobFound = 0 then
            if point(i,j,image1) <> rgb(0,0,0) then
                blobFound = 1
                'traverseBlob (x,y,destination,colorOfBlob,source)
                traverseBlob(i,j,image2,point(i,j,image1),image1)
                cls
                put (0,0), image2 'show outline
            end if
        end if
    next i
next j

print "number of points =";count
if count<>0 then
    for i as integer = 1 to count-1
        line (xp(i-1),yp(i-1))-(xp(i),yp(i)),rgb(255,255,0)
    next i
end if

'convert to data statements in a .bas text file.
dim as integer count2
OPEN "shape2.bas"  FOR OUTPUT AS #1
if count<>0 then
    print #1, "DATA ";
    for i as integer = 0 to count-1
        print #1,xp(i);",";yp(i);
        count2 = count2 + 1
        if count2>10 then  'new line
            print #1,
            print #1,"DATA ";
            count2 = 0
        else
            print #1,",";
        end if
    next i
end if
CLOSE #1

sleep

The above version uses FBImage.bi to load a .png file
FBImage.bi

Code: Select all

#ifndef __FBImage_bi__
#define __FBImage_bi__


#ifdef __FB_WIN32__
# libpath "lib/win"
#else
# libpath "lib/lin"
#endif

#ifndef __FB_64BIT__
# inclib "FBImage-32-static"
#else
# inclib "FBImage-64-static"
#endif


' Load BMP, PNG, JPG, TGA, DDS from file or memory as FBImage

' screenres 640,480,32 ' <--- RGBA
' var jpg = LoadRGBAFile("test_rgb.jpg")
' put (0,0),jpg,PSET
'
' var png = LoadRGBAFile("test_rgba.png")
' put (256,0),png,ALPHA

' var img = LoadRGBAFile("filenotfound.xxx")
' if img=0 then
'   print "error: loading filenotfound.xxx " & *GetLastResult()
' end if

' Save RGB image as PNG
' var ok = SavePNGFile(img,"test_rgb.png")

' Save RGBA image as PNG
' var ok = SavePNGFile(img,"test_rgba.png",true)

extern "C"

declare function LoadRGBAFile(byval filename as const zstring ptr) as any ptr

declare function LoadRGBAMemory(byval buffer as const any ptr, byval buffersize as long) as any ptr

declare function GetLastResult() as const zstring ptr

declare function SavePNGFile (byval img as any ptr, byval filename as const zstring ptr,byval saveAlpha as boolean=false) as boolean

end extern

' load (32bit) RGBA image and convert it for 16 bit RGB mode
function Load16BitRGB(filename as const zstring ptr) as any ptr
  #define RGB16(_r,_g,_b) ((((_b) shr 3) shl 11) or (((_g) shr 2) shl 5) or ((_r) shr 3))
  var imgSrc = LoadRGBAFile(filename)
  if imgSrc=0 then return 0
  dim as integer w,h,spitch,dpitch
  dim as ubyte ptr s
  imageinfo imgSrc,w,h,,spitch,s
  var imgDst = ImageCreate(w,h,0,16)
  dim as ushort ptr d
  imageinfo imgDst,,,,dpitch,d
  dpitch shr= 1 ' pitch in bytes to pitch in pixels
  for y as integer =1 to h
    dim as integer i
    for x as integer =0 to w-1
      d[x] = RGB16(s[i],s[i+1],s[i+2])
      i+=4 ' next source pixel
    next
    s+=spitch ' next src row
    d+=dpitch ' next dst row
  next
  ImageDestroy imgSrc
  return imgDst
  #undef RGB16
end function

namespace Base64
  static as string*64 B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" _
                          & "abcdefghijklmnopqrstuvwxyz" _
                          & "0123456789+/"

  Function EncodeMemory(buffer as any ptr,size as long) As String
    #define E0 (S[j] shr 2)
    #define E1 (((S[j] and &H03) shl 4) + (S[j+1] shr 4))
    #define E2 (((S[j+1] and &H0F) shl 2) + (S[j+2] shr 6))
    #define E3 (S[j+2] and &H3F)
    dim as long nChars = size
    if nChars=0 then return ""
    dim as ubyte ptr S=buffer
    dim as long j,k,m = nChars mod 3
    dim as string r=string(((nChars+2)\3)*4,"=")
    nChars-= (m+1)
    For j = 0 To nChars Step 3
      r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+2]=B64[e2] : r[k+3]=B64[e3]:k+=4
    Next
    if m then
      r[k]=B64[e0] : r[k+1]=B64[e1] : r[k+3]=61
      If m = 2 Then r[k+2]=B64[e2] Else  r[k+2]=61
    end if
    return r
    #undef E0
    #undef E1
    #undef E2
    #undef E3
  End Function

  Function DecodeMemory(s As String,byref nBytes as integer) As any ptr
    #define P0(p) instr(B64,chr(s[n+p]))-1
    dim as long nChars=Len(s)
    if nChars<1 then return 0
    nBytes=nChars : nChars-=1
    dim as ubyte ptr O,buffer=callocate(nBytes)
    O=buffer
    for n As long = 0 To nChars Step 4
      var b = P0(1), c = P0(2), d = P0(3)
      if b>-1 then
        var a = P0(0) : *O = (a shl 2 + b shr 4) : O+=1
      end if
      if c>-1 then *O = (b shl 4 + c shr 2) : O+=1
      if d>-1 then *O = (c shl 6 + d) : O+=1
    next
    return buffer
    #undef P0
  end function
end namespace 

#endif ' __FBImage_bi__

[Richard]

Richard.
Do you use an editor to draw the fonts, it must have been a lot of work.
They would be very handy for games coders.

The reverse engineered stroke table is from my cloned PCB layout code.
I wrote this short converter code. It makes the initialisation array.
A little bit of editing followed to make it Static and reduce the redundant +- couples.

Code: Select all

'=======================================================================
Dim As Integer ch, i, w, n
Dim As Integer x0, y0, x1, y1, x2, y2
Dim As String txt, s( 32 To 127 )

'-----------------------------------------------------------------------
Open "draws.bas" For Output As #1
#define v(x) trim(str( x ))
Do
    Read ch, w, n
    x0 = 0  ' relative start position
    y0 = 0
    txt = "s(" + Str( ch ) + ") = """    ' initialise string array
    ' note: in FB, pixel y increases downwards, so reverse y order to negate
    For i = 1 To n  ' number of strokes
        Read x1, y1, x2, y2
        If ( x0 <> x1 ) Or ( y0 <> y1 ) Then ' first move to first stroke
            txt += " BM+" + v( x1 - x0 ) + "," + v( y0 - y1 )
        End If
        ' draw stroke
        txt += " M+" + v( x2 - x1 ) + "," + v( y1 - y2 )
        x0 = x2 ' update pen position to end of stroke
        y0 = y2
    Next i
    ' advance to start of next character
    txt += " BM+" + v( w - x0 ) + "," + v( y0 ) + """"
    Print txt
    Print #1, txt
Loop Until ch = 127
#undef v
Close #1

'=======================================================================
' original stroke table
' Each character is in a 6 unit high box with possible decenders -1 or -2.
' The majority of characters are four units wide, some less, V and W more.
' Only three characters ,; and < have a left protrusion to -1.
' The width of each character includes a following separator of two units,
'   but does not include the left protrusion that may exist.
'--------------------------------------------------------------------
' Ascii, Width, nStrokes, strokes(x1,y1,x2,y2),(....),(....)
Data  32,6, 0 ' spc
Data  33,2, 2, 0,0,0,1, 0,2,0,6 ' !
Data  34,3, 2, 0,4,0,6, 1,4,1,6 ' "
Data  35,6, 4, 1,0,1,6, 3,0,3,6, 0,2,4,2, 0,4,4,4 ' #
Data  36,6, 8, 0,1,3,1, 3,1,4,2, 4,2,3,3, 3,3,1,3, 1,3,0,4, 0,4,1,5, 1,5,4,5, 2,0,2,6 ' $
Data  37,6,11, 0,0,0,1, 0,1,4,5, 4,5,4,6, 0,6,1,6, 1,6,1,5, 1,5,0,5, 0,5,0,6, 3,0,3,1, 3,1,4,1, 4,1,4,0, 4,0,3,0 ' %
Data  38,6,10, 4,0,0,4, 0,4,0,5, 0,5,1,6, 1,6,2,5, 2,5,2,4, 2,4,0,2, 0,2,0,1, 0,1,1,0, 1,0,2,0, 2,0,4,2 ' &
Data  39,2, 1, 0,4,0,6 ' '
Data  40,4, 3, 2,0,0,2, 0,2,0,4, 0,4,2,6 ' (
Data  41,4, 3, 0,0,2,2, 2,2,2,4, 2,4,0,6 ' )
Data  42,6, 4, 0,1,4,5, 0,5,4,1, 2,1,2,5, 0,3,4,3 ' *
Data  43,6, 2, 2,1,2,5, 0,3,4,3 ' +
Data  44,2, 2,-1,-1,0,0,0,0,0,1 ' ,
Data  45,6, 1, 0,3,4,3 ' -
Data  46,2, 1, 0,0,0,1 ' .
Data  47,6, 3, 0,0,0,1, 0,1,4,5, 4,5,4,6 ' /

Data  48,6, 8, 1,0,0,1, 0,1,0,5, 0,5,1,6, 1,6,3,6, 3,6,4,5, 4,5,4,1, 4,1,3,0, 3,0,1,0 ' 0
Data  49,4, 3, 0,5,1,6, 1,6,1,0, 0,0,2,0 ' 1
Data  50,6, 9, 4,0,0,0, 0,0,0,2, 0,2,1,3, 1,3,3,3, 3,3,4,4, 4,4,4,5, 4,5,3,6, 3,6,1,6, 1,6,0,5 ' 2
Data  51,6,11, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,4,2, 4,2,3,3, 3,3,4,4, 4,4,4,5, 4,5,3,6, 3,6,1,6, 1,6,0,5, 2,3,3,3 ' 3
Data  52,6, 4, 3,0,3,6, 3,6,0,3, 0,3,0,2, 0,2,4,2 ' 4
Data  53,6, 8, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,4,3, 4,3,3,4, 3,4,0,4, 0,4,0,6, 0,6,4,6 ' 5
Data  54,6, 9, 0,3,3,3, 3,3,4,2, 4,2,4,1, 4,1,3,0, 3,0,1,0, 1,0,0,1, 0,1,0,4, 0,4,2,6, 2,6,3,6 ' 6
Data  55,6, 4, 0,0,0,1, 0,1,4,5, 4,5,4,6, 4,6,0,6 ' 7
Data  56,6,15, 1,0,0,1, 0,1,0,2, 0,2,1,3, 1,3,0,4, 0,4,0,5, 0,5,1,6, 1,6,3,6, 3,6,4,5, 4,5,4,4, 4,4,3,3, 3,3,4,2, 4,2,4,1, 4,1,3,0, 3,0,1,0, 1,3,3,3 ' 8
Data  57,6, 9, 1,0,2,0, 2,0,4,2, 4,2,4,5, 4,5,3,6, 3,6,1,6, 1,6,0,5, 0,5,0,4, 0,4,1,3, 1,3,4,3 ' 9

Data  58,2, 2, 0,1,0,2, 0,3,0,4 ' :
Data  59,2, 3,-1,-1,0,0, 0,0,0,2, 0,3,0,4 ' ;
Data  60,4, 2, 2,0,-1,3, -1,3,2,6 ' <
Data  61,6, 2, 0,2,4,2, 0,4,4,4 ' =
Data  62,5, 2, 0,0,3,3, 3,3,0,6 ' >
Data  63,5, 7, 2,0,2,1, 2,2,2,3, 2,3,3,4, 3,4,3,5, 3,5,2,6, 2,6,1,6, 1,6,0,5 ' ?
Data  64,6,11, 2,1,2,2, 2,2,1,3, 1,3,0,2, 0,2,0,1, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,4,5, 4,5,3,6, 3,6,1,6, 1,6,0,5 ' @

Data  65,6, 5, 0,0,0,2, 0,2,2,6, 2,6,4,2, 4,2,4,0, 0,2,4,2 ' A
Data  66,6,10, 0,0,3,0, 3,0,4,1, 4,1,4,2, 4,2,3,3, 3,3,4,4, 4,4,4,5, 4,5,3,6, 3,6,0,6, 1,0,1,6, 1,3,3,3 ' B
Data  67,6, 7, 4,1,3,0, 3,0,1,0, 1,0,0,1, 0,1,0,5, 0,5,1,6, 1,6,3,6, 3,6,4,5 ' C
Data  68,6, 6, 0,0,3,0, 3,0,4,1, 4,1,4,5, 4,5,3,6, 3,6,0,6, 1,0,1,6 ' D
Data  69,6, 4, 4,0,0,0, 0,0,0,6, 0,6,4,6, 0,3,2,3 ' E
Data  70,6, 3, 0,0,0,6, 0,6,4,6, 0,3,2,3 ' F
Data  71,6, 7, 3,3,4,3, 4,3,4,0, 4,0,1,0, 1,0,0,1, 0,1,0,5, 0,5,1,6, 1,6,4,6 ' G
Data  72,6, 3, 0,0,0,6, 4,0,4,6, 0,3,4,3 ' H
Data  73,4, 3, 0,0,2,0, 0,6,2,6, 1,0,1,6 ' I
Data  74,6, 4, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,4,6 ' J
Data  75,6, 4, 0,0,0,6, 0,3,1,3, 4,0,1,3, 1,3,4,6 ' K
Data  76,6, 2, 4,0,0,0, 0,0,0,6 ' L
Data  77,6, 4, 0,0,0,6, 0,6,2,2, 2,2,4,6, 4,6,4,0 ' M
Data  78,6, 3, 0,0,0,6, 0,6,4,2, 4,0,4,6 ' N
Data  79,6, 4, 0,0,0,6, 0,6,4,6, 4,6,4,0, 4,0,0,0 ' O
Data  80,6, 6, 0,0,0,6, 0,6,3,6, 3,6,4,5, 4,5,4,4, 4,4,3,3, 3,3,0,3 ' P
Data  81,6, 9, 4,0,2,2, 4,2,2,0, 2,0,1,0, 1,0,0,1, 0,1,0,5, 0,5,1,6, 1,6,3,6, 3,6,4,5, 4,5,4,2 ' Q
Data  82,6, 7, 0,0,0,6, 0,6,3,6, 3,6,4,5, 4,5,4,4, 4,4,3,3, 3,3,0,3, 1,3,4,0 ' R
Data  83,6, 7, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,0,5, 0,5,1,6, 1,6,3,6, 3,6,4,5 ' S
Data  84,6, 2, 2,0,2,6, 0,6,4,6 ' T
Data  85,6, 5, 0,6,0,1, 0,1,1,0, 1,0,3,0, 3,0,4,1, 4,1,4,6 ' U
Data  86,8, 2, 0,6,3,0, 3,0,6,6 ' V
Data  87,8, 7, 0,6,0,1, 0,1,1,0, 1,0,3,2, 3,2,5,0, 5,0,6,1, 6,1,6,6, 3,2,3,3 ' W
Data  88,6, 6, 0,0,0,1, 0,1,4,5, 4,5,4,6, 4,0,4,1, 4,1,0,5, 0,5,0,6 ' X
Data  89,6, 5, 2,0,2,3, 0,6,0,5, 0,5,2,3, 2,3,4,5, 4,5,4,6 ' Y
Data  90,6, 5, 4,0,0,0, 0,0,0,1, 0,1,4,5, 4,5,4,6, 4,6,0,6 ' Z

Data  91,4, 3, 2,0,0,0, 0,0,0,6, 0,6,2,6 ' [
Data  92,6, 3, 0,6,0,5, 0,5,4,1, 4,1,4,0 ' \
Data  93,4, 3, 0,0,2,0, 2,0,2,6, 2,6,0,6 ' ]
Data  94,6, 3, 0,4,2,6, 2,6,4,4, 2,6,2,0 ' ^
Data  95,6, 1, 0,-1,4,-1 ' _
Data  96,4, 1, 0,6,2,4 ' `

Data  97,6, 9, 3,1,2,0, 2,0,1,0, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,2,4, 2,4,3,3, 3,3,3,1, 3,1,4,0 ' a
Data  98,6, 8, 0,0,0,6, 0,2,2,0, 2,0,3,0, 3,0,4,1, 4,1,4,3, 4,3,3,4, 3,4,2,4, 2,4,0,2 ' b
Data  99,6, 5, 4,0,1,0, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,4,4 ' c
Data 100,6, 8, 4,0,4,6, 4,2,2,0, 2,0,1,0, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,2,4, 2,4,4,2 ' d
Data 101,6, 8, 3,0,1,0, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,3,4, 3,4,4,3, 4,3,3,2, 3,2,0,2 ' e
Data 102,6, 5, 1,0,1,5, 1,5,2,6, 2,6,3,6, 3,6,4,5, 0,3,3,3 ' f
Data 103,6,10, 0,-1,1,-2, 1,-2,3,-2, 3,-2,4,-1, 4,-1,4,3, 4,3,3,4, 3,4,1,4, 1,4,0,3, 0,3,0,1, 0,1,1,0, 1,0,4,0 ' g
Data 104,6, 5, 0,0,0,6, 0,2,2,4, 2,4,3,4, 3,4,4,3, 4,3,4,0 ' h
Data 105,2, 2, 0,0,0,3, 0,4,0,5 ' i
Data 106,5, 5, 0,-1,1,-2, 1,-2,2,-2, 2,-2,3,-1, 3,-1,3,3, 3,4,3,5 ' j
Data 107,6, 4, 0,0,0,6, 0,2,2,2, 4,0,2,2, 2,2,4,4 ' k
Data 108,3, 2, 1,0,0,1, 0,1,0,6 ' l
Data 109,6, 7, 0,0,0,4, 0,3,1,4, 1,4,2,3, 2,3,3,4, 3,4,4,3, 4,3,4,0, 2,2,2,3 ' m
Data 110,5, 5, 0,0,0,4, 0,3,1,4, 1,4,2,4, 2,4,3,3, 3,3,3,0 ' n
Data 111,6, 8, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,3,4, 3,4,4,3, 4,3,4,1, 4,1,3,0, 3,0,1,0 ' o
Data 112,6, 7, 0,-2,0,4,0,0,3,0, 3,0,4,1, 4,1,4,3, 4,3,3,4, 3,4,1,4, 1,4,0,3 ' p
Data 113,6, 7, 4,-2,4,4,4,0,1,0, 1,0,0,1, 0,1,0,3, 0,3,1,4, 1,4,3,4, 3,4,4,3 ' q
Data 114,6, 4, 0,0,0,4, 0,2,2,4, 2,4,3,4, 3,4,4,3 ' r
Data 115,6, 7, 0,0,3,0, 3,0,4,1, 4,1,3,2, 3,2,1,2, 1,2,0,3, 0,3,1,4, 1,4,4,4 ' s
Data 116,6, 4, 4,1,3,0, 3,0,2,1, 2,1,2,6, 0,4,4,4 ' t
Data 117,6, 5, 0,4,0,1, 0,1,1,0, 1,0,2,0, 2,0,4,2, 4,0,4,4 ' u
Data 118,6, 2, 0,4,2,0, 2,0,4,4 ' v
Data 119,6, 7, 0,4,0,1, 0,1,1,0, 1,0,2,1, 2,1,3,0, 3,0,4,1, 4,1,4,4, 2,1,2,2 ' w
Data 120,6, 2, 0,0,4,4, 0,4,4,0 ' x
Data 121,6, 7, 0,4,0,1, 0,1,1,0, 1,0,2,0, 2,0,4,2, 1,-2,3,-2, 3,-2,4,-1, 4,-1,4,4 ' y
Data 122,6, 3, 0,4,4,4, 4,4,0,0, 0,0,4,0 ' z

Data 123,4, 6, 2,0,1,1, 1,1,1,2, 1,2,0,3, 0,3,1,4, 1,4,1,5, 1,5,2,6 ' {
Data 124,2, 1, 0,0,0,6 ' |
Data 125,4, 6, 0,0,1,1, 1,1,1,2, 1,2,2,3, 2,3,1,4, 1,4,1,5, 1,5,0,6 ' }
Data 126,6, 3, 0,1,1,2, 1,2,3,2, 3,2,4,3 ' ~
Data 127,6, 8, 0,0,0,6, 0,6,4,6, 4,6,4,0, 4,0,0,0, 0,0,4,6, 0,6,4,0, 0,3,4,3, 2,0,2,6