gmgauthier/freebasic-examples
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
Greg Gauthier 2023-07-09 12:18:33 +01:00
commit b04d90ff0d
67 changed files with 3300 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
bin/addsub Executable file
View File

Binary file not shown.

BIN
bin/answer Executable file
View File

Binary file not shown.

BIN
bin/clooper Executable file
View File

Binary file not shown.

BIN
bin/colors Executable file
View File

Binary file not shown.

BIN
bin/conv Executable file
View File

Binary file not shown.

BIN
bin/drawtest Executable file
View File

Binary file not shown.

BIN
bin/fbpaint Executable file
View File

Binary file not shown.

BIN
bin/fbpanel Executable file
View File

Binary file not shown.

BIN
bin/hello Executable file
View File

Binary file not shown.

BIN
bin/inkey Executable file
View File

Binary file not shown.

BIN
bin/makdword Executable file
View File

Binary file not shown.

BIN
bin/repeats Executable file
View File

Binary file not shown.

BIN
bin/screenres Executable file
View File

Binary file not shown.

BIN
bin/simplebox Executable file
View File

Binary file not shown.

BIN
bin/statics Executable file
View File

Binary file not shown.

BIN
bin/tui Executable file
View File

Binary file not shown.

BIN
bin/tuibox Executable file
View File

Binary file not shown.

BIN
bin/tutorial Executable file
View File

Binary file not shown.

BIN
bin/weights Executable file
View File

Binary file not shown.

BIN
bin/width Executable file
View File

Binary file not shown.

35
src/addsub.fb.bas Normal file
View File

@ -0,0 +1,35 @@
#lang "fblite"
dim as integer max,a,b,n,i
print
input "Maximum absolute value of the numbers [default: 100]: ";max
if max<2 then
max=100
end if
print
input "How many examples [default: 25] ";n
if n<=0 then
n=25
end if
Print ' output on the printer
Print
Print
Print " ";n;" arithmetical exercises with integral numbers from ";-max;" to";max
Print
Print
randomize 'initialize the rnd random-number generator
for i=1 to n
a=int(rnd*(2*max+1))-max
b=int(rnd*(2*max+1))-max
Print using " ###) ";i;
Print a;
if b<=0 then
Print " -";abs(b)
else
Print " +";b
end if
'Print
'Print
next i
Print Chr(12) ' for output on computer screen use the command "sleep"

3
src/answer.fb.bas Normal file
View File

@ -0,0 +1,3 @@
Dim answer As String
Input "Type something, you idiot! ", answer
Print "You typed: '";answer;"'"

32
src/clooper.fb.bas Normal file
View File

@ -0,0 +1,32 @@
Cls
Print "Standard Sixteen Color Test"
Sleep 2000
For b As Integer = 0 to 15
For f As Integer = 0 to 15
Cls
Locate 10,15
Color f,b:Print "Foreground: "; f; " Background: "; b;" ";:Color 7,0:Print
Sleep 125
Next f
Next b
Color 7,0
Print "Press Any Key...":Sleep
Cls
Print "RGB Color Test: 256 Random RGB Values..."
Sleep 2000
Randomize 2, 1
For i As Integer = 1 to 256
dim as Integer last,first
last = 254:first = 0
dim as Integer r,g,b
r = cast(integer, fix(rnd*(last-first))+first)
g = cast(integer, fix(rnd*(last-first))+first)
b = cast(integer, fix(rnd*(last-first))+first)
Cls
Locate 10,15
Color RGB(r,g,b), RGB(b,r,g):Print "Color Count: ";i;" Foreground: (";r;",";g;",";b;")";" Background: (";b;",";g;",";r;")";:Color 7,0:Print
Sleep 125
Next i
Print "Press any key...":Sleep:Cls

13
src/colors.fb.bas Normal file
View File

@ -0,0 +1,13 @@
Dim As Integer clr, ccode
Color 15,0
clr = Color
Print "Current color setting:"
Print "Foreground: ";Loword(clr)
Print "Background: ";Hiword(clr)
Print
ccode = Screen(0, 0)
Print "Character code at 1,1 is";ccode;" which is ";Chr(ccode);"."
clr = Screen(1, 1, 1)
Print "Foreground color at 1,1:";clr And 15
Print "Background color at 1,1:";clr Shr 4
End

7
src/conv.fb.bas Normal file
View File

@ -0,0 +1,7 @@
Dim As Double myDbl
Dim As Integer myInt
myDbl = 5.56
myInt = myDbl
print "myInt = "; myInt
Sleep
End

18
src/drawtest.fb.bas Normal file
View File

@ -0,0 +1,18 @@
Cls
Locate 1, 10
'Color 15, 1
'Print space( 50 );
'Locate 12, 12
'print "Hello World";
'Print Point(1,10)
Sub DrawTextBox(ByVal x as Integer, ByVal y as Integer, _
ByVal TextWidth as Integer, ByVal FieldLen as Integer, _
ByVal TabAble as Integer = 0, ByVal Label as String)
Color 15,1:Locate y,x:Print Label;:Locate y,x+TextWidth:Print "[";
Locate y,x+TextWidth+FieldLen-1:Print "]";
End Sub
DrawTextBox 25,5,10,33,1, "Name:"

BIN
src/fbfonts/fb_fonts.zip Normal file
View File

Binary file not shown.

BIN
src/fbfonts/upload/demo Executable file
View File

Binary file not shown.

47
src/fbfonts/upload/demo.bas Normal file
View File

@ -0,0 +1,47 @@
Const depth=8
#Include Once "gfx.bi"
#Include Once "font.bi"
ScreenRes 640,480,depth
Dim As TFont SerifRed,SansBlue,MonoGreen,Serif,Sans,Mono,Sans18,Sans30
SerifRed.Load("serif.fnt",&hd83f3f)
MonoGreen.Load("mono.fnt",&h13c86b)
SansBlue.Load("sans.fnt",&h729fcf)
Sans.Load("sans.fnt")
Serif.Load("serif.fnt")
Mono.Load("mono.fnt")
Sans18.Load("sans.fnt"):Sans18.ChangeSize(18)
Sans30.Load("sans.fnt"):Sans30.ChangeSize(30)
Line (0,0)-(640,480),GetColor(&h2e3436),BF
Serif.DrawString(,"ÄÖÜäöüß éÈáÀóÒúÙíÌć ĄĘñ âêô ¿ €",10,10)
SerifRed.DrawString(,"Freeserif",10,30)
Serif.DrawString(,"Freeserif Bold",100,30,True)
Serif.DrawString(,"Freeserif Italic",220,30,,,True)
Serif.DrawString(,"Freeserif Underlined",340,30,,True)
SansBlue.DrawString(,"Freesans",10,80)
Sans.DrawString(,"Freesans Bold",100,80,True)
Sans.DrawString(,"Freesans Italic",220,80,,,True)
Sans.DrawString(,"Freesans Underlined",340,80,,True)
MonoGreen.DrawString(,"Freemono",10,130)
Mono.DrawString(,"Freemono Bold",100,130,True)
Mono.DrawString(,"Freemono Italic",220,130,,,True)
Mono.DrawString(,"Freemono Underlined",340,130,,True)
Serif.DrawString(,"Basic Latin: Good evening FreeBasic - Community and others",10,180)
Serif.DrawString(,"German: Hallöchen! Stinkefüße und Äpfel kosten 1000 €uros",10,200)
Serif.DrawString(,"Portuguese/Spanish: Olá amigos ¿Cómo estás? Eñe Freebasic é ótimo",10,220)
Serif.DrawString(,"Polish: Się granicą filmów Ęsiąząt",10,240)
Sans.DrawString(,"Freesans 11",10,300)
Sans18.DrawString(,"Freesans 18",10,320)
Sans30.DrawString(,"Freesans 30",10,350)
Sans.DrawString(,"Bold, Italic and Unterlined!",10,450,True,True,True)
Sleep
End

495
src/fbfonts/upload/font.bi Normal file
View File

@ -0,0 +1,495 @@
Type TFont
As Any Ptr Char(103),CharItalic(103)
As UByte wide(103)
As UByte size,origsize
As Integer clr
Declare Sub Load(file As String, clrc As Integer=&hffffff)
Declare Sub DrawString(buffer As Any Ptr=0,text As String,x As Integer,y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False)
Declare Sub Render(buffer As Any Ptr=0,charid As UByte,x As Integer, y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False)
Declare Sub CombinedRender(buffer As Any Ptr=0,charid As UByte,charid2 As UByte,x As Integer, y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False,down As Boolean=False,plusx As Integer=0,plusy As Integer=0)
'Declare Sub ChangeColor(clr As Integer)
Declare Sub ChangeSize(newsize As UByte)
Declare Function Length(text As WString) As Integer
End Type
Sub TFont.Load(file As String, clrc As Integer=&hffffff)
clr=GetColor(clrc)
Dim As UByte in
Dim As Integer wholewide,start
Dim As Any Ptr fntimg
Var ff=FreeFile
Open file For Binary As #ff
Get #ff,0,size
origsize=size
For i As Integer=1 To 101
If wide(1)=&hFF Then
wide(i)=7
Else
Get #ff,,wide(i)
End If
Char(i)=ImageCreate(wide(i),size-1)
CharItalic(i)=ImageCreate(wide(i)+2,size-1)
wholewide+=wide(i)
Next
Char(102)=ImageCreate(Wide(64),size-1)
CharItalic(102)=ImageCreate(Wide(64)+2,size-1)
Char(103)=ImageCreate(Wide(31),size-1)
CharItalic(103)=ImageCreate(Wide(31)+2,size-1)
Wide(103)=Wide(31)
If wide(1)=&hFF Then wide(1)=7:start=1
fntimg=ImageCreate(wholewide,size)
For x As Integer=start To wholewide Step 8
For y As Integer=0 To size-1
Get #ff,,in
For i As Integer=1 To 8
If Bit(in,8-i)=True Then
Pset fntimg,(x+(i-1),y),clr
End If
Next
Next
Next
Close #ff
wholewide=0
For i As Integer=1 To 101
Get fntimg,(wholewide,0)-(wholewide+wide(i)-1,size-1),Char(i)
wholewide+=wide(i)
For x As UByte=0 To Wide(i)-1
For y As UByte=0 To size-1
If depth<=8 Then
If Point(x,y,Char(i))=clr Then
If y<(size-1)/3 Then
Pset CharItalic(i),(x+2,y),clr
ElseIf y>((size-2)/3)*2 Then
Pset CharItalic(i),(x,y),clr
Else
Pset CharItalic(i),(x+1,y),clr
End If
End If
ElseIf depth=16 Then
If Point(x,y,Char(i))<>&hff00ff Then
If y<(size-1)/3 Then
Pset CharItalic(i),(x+2,y),clr
ElseIf y>((size-2)/3)*2 Then
Pset CharItalic(i),(x,y),clr
Else
Pset CharItalic(i),(x+1,y),clr
End If
End If
Else
If Point(x,y,Char(i))<>&hffff00ff Then
'If y<(size-1)/2 Then
'Pset CharItalic(i),(x+2,y),clr
'ElseIf y>((size-2)/3)*2 Then
Pset CharItalic(i),(x,y),clr
'Else
' Pset CharItalic(i),(x+1,y),clr
'End If
End If
End If
Next
Next
Next
Char(102)=MirrorImage(Char(64),2,clr)
CharItalic(102)=MirrorImage(CharItalic(64),2,clr)
Char(103)=MirrorImage2(Char(31),-1,clr,-3)
CharItalic(103)=MirrorImage2(CharItalic(31),1,clr,-3)
ImageDestroy fntimg
End Sub
Sub TFont.Render(buffer As Any Ptr=0,charid As UByte,x As Integer, y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False)
If italic=True Then
Put buffer,(x,y),CharItalic(charid),trans
If bold=True Then Put buffer,(x+1,y),CharItalic(charid),trans
Else
Put buffer,(x,y),Char(charid),trans
If bold=True Then Put buffer,(x+1,y),Char(charid),trans
End If
End Sub
Sub TFont.CombinedRender(buffer As Any Ptr=0,charid As UByte,charid2 As UByte,x As Integer, y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False,down As Boolean=False,plusx As Integer=0,plusy As Integer=0)
If italic=True Then
Put buffer,(x,y),CharItalic(charid),trans
If down=True Then
Put buffer,(x+plusx,y+size-3-plusy),CharItalic(charid2),trans
Else
Put buffer,(x+plusx,y-plusy),CharItalic(charid2),trans
End If
If bold=True Then
Put buffer,(x+1,y),CharItalic(charid),Trans
If down=True Then
Put buffer,(x+1+plusx,y+size-3-plusy),CharItalic(charid2),trans
Else
Put buffer,(x+1+plusx,y-plusy),CharItalic(charid2),trans
End If
End If
Else
Put buffer,(x,y),Char(charid),trans
If down=True Then
Put buffer,(x+plusx,y+size-3-plusy),Char(charid2),trans
Else
Put buffer,(x+plusx,y-plusy),Char(charid2),trans
End If
If bold=True Then
Put buffer,(x+1,y),Char(charid),Trans
If down=True Then
Put buffer,(x+1+plusx,y+size-3-plusy),Char(charid2),trans
Else
Put buffer,(x+1+plusx,y-plusy),Char(charid2),trans
End If
End If
End If
End Sub
Sub TFont.DrawString(buffer As Any Ptr=0,text As String,x As Integer,y As Integer,bold As Boolean=False,underline As Boolean=False,italic As Boolean=False)
Dim As UByte charid,charid2
Dim As Byte plusx,plusy
Dim As Boolean down
Dim As UShort textlength
For i As Integer=0 To Len(text)
charid=text[i]-32
charid2=0
down=False
plusx=0
plusy=0
If text[i]<33 Then
textlength+=3
charid=0
ElseIf charid=162 Then
charid=text[i+1]-32
i+=1
If charid=159 Then
charid=103
textlength+=wide(103)
End If
ElseIf charid=194 Then
charid=text[i+1]-32
i+=1
If charid=98 Then
charid=text[i+1]-32
i+=1
If charid=140 Then
charid=101
textlength+=wide(101)
End If
End If
Elseif charid=164 Then
charid=text[i+1]-32
i+=1
If charid=100 Then 'Ą
charid=33
charid2=64
textlength+=wide(33)
down=True
plusx=6
Elseif charid=101 Then 'ą
charid=65
charid2=64
textlength+=wide(65)
down=True
plusx=3
ElseIf charid=102 Then
charid=35
charid2=102
textlength+=wide(35)
plusy=2
plusx=3
ElseIf charid=103 Then
charid=67
charid2=102
textlength+=wide(67)
ElseIf charid=120 Then 'Ę
charid=37
charid2=102
textlength+=wide(37)
plusy=2
plusx=2
Elseif charid=121 Then
charid=69
charid2=64
textlength+=wide(69)
down=True
plusx=3
End If
ElseIf charid=163 Then
charid=text[i+1]+32
i+=1
Select Case charid
Case 220 'ü
charid=99
textlength+=wide(99)
Case 196 'ä
charid=97
textlength+=wide(97)
Case 164 'Ä
charid=94
textlength+=wide(94)
Case 214 'ö
charid=98
textlength+=wide(98)
Case 182 'Ö
charid=95
textlength+=wide(95)
Case 188 'Ü
charid=96
textlength+=wide(96)
Case 191 'ß
charid=100
textlength+=wide(100)
'Case 140 '€
'charid=101
'textlength+=wide(101)
Case 162 'â
charid=33
charid2=62
textlength+=wide(33)
plusy=3
Case 170 'ê
charid=37
charid2=62
textlength+=wide(37)
plusy=4
Case 180 'Ô
charid=47
charid2=62
textlength+=wide(47)
plusy=4
Case 194 'â
charid=65
charid2=62
textlength+=wide(65)
plusy=2
plusx=-1
Case 202 'ê
charid=69
charid2=62
textlength+=wide(69)
plusy=2
plusx=-1
Case 212 'ô
charid=79
charid2=62
textlength+=wide(79)
plusy=2
plusx=-1
Case 166 'Æ
charid=33
charid2=37
textlength+=wide(33)+6
plusx=6
Case 198 'Æ
charid=65
charid2=69
textlength+=wide(65)+5
plusx=5
Case 209 'ñ
charid=78
charid2=63
textlength+=wide(78)
plusy=size-2
Case 160 'À
charid=33
charid2=64
textlength+=wide(33)
plusy=2
plusx=2
Case 161 'À
charid=33
charid2=102
textlength+=wide(33)
plusy=2
plusx=2
Case 168 'É
charid=37
charid2=64
textlength+=wide(37)
plusy=2
plusx=2
Case 169 'É
charid=37
charid2=102
textlength+=wide(37)
plusy=2
plusx=2
Case 172 'Ì
charid=41
charid2=64
textlength+=wide(41)
plusy=2
Case 173 'Ì
charid=41
charid2=102
textlength+=wide(41)
plusy=2
Case 178 'Ò
charid=47
charid2=64
textlength+=wide(47)
plusy=2
plusx=2
Case 179 'Ò
charid=47
charid2=102
textlength+=wide(47)
plusy=2
plusx=2
Case 185 'Ù
charid=53
charid2=64
textlength+=wide(53)
plusy=2
plusx=2
Case 186 'Ù
charid=53
charid2=102
textlength+=wide(53)
plusy=2
plusx=2
Case 230 'Ć
charid=35
charid2=102
textlength+=wide(35)
plusy=2
plusx=3
Case 192 'à
charid=65
charid2=64
textlength+=wide(65)
Case 193 'á
charid=65
charid2=102
textlength+=wide(65)
Case 200 'é
charid=69
charid2=64
textlength+=wide(69)
Case 201 'é
charid=69
charid2=102
textlength+=wide(69)
Case 204 'í
charid=73
charid2=64
textlength+=wide(74)
Case 205 'í
charid=73
charid2=102
textlength+=wide(74)
Case 210 'ó
charid=79
charid2=64
textlength+=wide(79)
Case 211 'ó
charid=79
charid2=102
textlength+=wide(79)
Case 217 'ú
charid=85
charid2=64
textlength+=wide(85)
Case 218 'ú
charid=85
charid2=102
textlength+=wide(85)
Case 228 'Ą
charid=33
charid2=64
textlength+=wide(33)
down=True
plusx=6
Case 229 'ą
charid=65
charid2=64
textlength+=wide(65)
down=True
plusx=3
Case 231 'ć
charid=67
charid2=102
textlength+=wide(67)
Case 248 'Ę
charid=37
charid2=64
textlength+=wide(37)
down=True
plusx=4
Case 249 'ę
charid=69
charid2=64
textlength+=wide(69)
down=True
plusx=3
Case Else
textlength+=3
End Select
Else
textlength+=wide(charid)
End If
If charid<>0 Then
If charid2<>0 Then
CombinedRender(buffer,charid,charid2,x+textlength-wide(charid),y,bold,,italic,down,plusx,plusy)
Else
Render(buffer,charid,x+textlength-wide(charid),y,bold,,italic)
End If
End If
'Draw String (10,40+i*20),Str(charid)+"|"+Str(Len(text))
If bold=True Then textlength+=1
If underline=True Then
Line (x,y+size+1)-(x+textlength,y+size+1),clr
End If
Next
End Sub
'Sub TFont.ChangeColor(clrc As Integer)
'Var clr2=GetColor(clrc)
'For i As Integer=1 To 102
'For y As Integer=0 To size-1
'For x As Integer=0 To wide(i)+2
'If Point(x,y,char(i))=clr Then
'Pset char(i),(x,y),clr2
'End If
'If Point(x,y,charitalic(i))=clr Then
'Pset charitalic(i),(x,y),clr2
'End If
'Next
'Next
'Next
'clr=clr2
'End Sub
Sub TFont.ChangeSize(newsize As UByte)
size=newsize
Dim As Integer oldwide
For i As Integer=1 To 102
oldwide=Wide(i)
Wide(i)=Wide(i)+(size-origsize)
Char(i)=Resize(Char(i),Wide(i)/oldwide,size/origsize)
Next
End Sub
Function TFont.Length(text As WString) As Integer
Dim As Integer textlength
Dim As UByte charid
For i As Integer=0 To Len(text)
charid=text[i]-32
If charid<33 Then
textlength+=3
Else
textlength+=wide(charid)
End If
Next
Return textlength
End Function

121
src/fbfonts/upload/gfx.bi Normal file
View File

@ -0,0 +1,121 @@
#define RGBA_R(c) (CUInt(c) Shr 16 And 255)
#define RGBA_G(c) (CUInt(c) Shr 8 And 255)
#define RGBA_B(c) (CUInt(c) And 255)
'#define RGBA_A(c) (CUInt(c) Shr 24 )
Function GetDistanceBetweenColours(a As Integer, b As Integer) As Integer
Var ra=RGBA_R(a)
Var ga=RGBA_G(a)
Var ba=RGBA_B(a)
Var rb=RGBA_R(b)
Var gb=RGBA_G(b)
Var bb=RGBA_B(b)
dim as integer dR = ra - rb
dim as integer dG = ga - gb
dim as integer dB = ba - bb
return dR * dR + dG * dG + dB * dB
End Function
Function GetColor(clr As Integer)As Integer
Dim As Integer plt4(15)={&h000000, &h000080, &h008000, &h241200, &h800000, &h800080, &h808000, &hc0c0c0, &h808080, &h0000FF, &h00FF00, &h00FFFF, &hFF0000, &hFF00FF, &hFFFF00, &hFFFFFF}
Dim As Integer plt8(255)={&h000080, &h008000, &h241200, &h800000, &h800080, &h808000, &hc0c0c0, &h808080, &h0000FF, &h00FF00, &h00FFFF, &hFF0000, &hFF00FF, &hFFFF00, &hFFFFFF, &h000000, &h141414, &h202020, &h2C2C2C, &h383838, &h444444, &h505050, &h616161, &h717171, &h818181, &h919191, &hA1A1A1, &hB6B6B6, &hCACACA, &hE2E2E2, &hFFFFFF, &h0000FF, &h4000FF, &h7D00FF, &hBE00FF, &h000000, &hFF00BE, &hFF007D, &hFF0040, &hFF0000, &hFF4000, &hFF7D00, &hFFBE00, &hFFFF00, &hBEFF00, &h7DFF00, &h40FF00, &h00FF00, &h00FF40, &h00FF7D, &h00FFBE, &h00FFFF, &h00BEFF, &h007DFF, &h0040FF, &h7D7DFF, &h9D7DFF, &hBE7DFF, &hDE7DFF, &hFF7DFF, &hFF7DDE, &hFF7DBE, &hFF7D9D, &hFF7D7D, &hFF9D7D, &hFFBE7D, &hFFDE7D, &hFFFF7D, &hDEFF7D, &hBEFF7D, &h9DFF7D, &h7DFF7D, &h7DFF9D, &h7DFFBE, &h7DFFDE, &h7DFFFF, &h7DDEFF, &h7DBEFF, &h7D9DFF, &hB6B6FF, &hC6B6FF, &hDAB6FF, &hEAB6FF, &hFFB6FF, &hFFB6EA, &hFFB6DA, &hFFB6C6, &hFFB6B6, &hFFC6B6, &hFFDAB6, &hFFEAB6, &hFFFFB6, &hEAFFB6, &hDAFFB6, &hC6FFB6, &hB6FFB6, &hB6FFC6, &hB6FFDA, &hB6FFEA, &hB6FFFF, &hB6EAFF, &hB6DAFF, &hB6C6FF, &h000071, &h1C0071, &h380071, &h550071, &h710071, &h710055, &h710038, &h71001C, &h710000, &h711C00, &h713800, &h715500, &h717100, &h557100, &h387100, &h1C7100, &h007100, &h00711C, &h007138, &h007155, &h007171, &h005571, &h003871, &h001C71, &h383871, &h443871, &h553871, &h613871, &h713871, &h713861, &h713855, &h713844, &h713838, &h714438, &h715538, &h716138, &h717138, &h617138, &h557138, &h447138, &h387138, &h387144, &h387155, &h387161, &h387171, &h386171, &h385571, &h384471, &h505071, &h595071, &h615071, &h695071, &h715071, &h715069, &h715061, &h715059, &h715050, &h715950, &h716150, &h716950, &h717150, &h697150, &h617150, &h597150, &h507150, &h507159, &h507161, &h507169, &h507171, &h506971, &h506171, &h505971, &h000040, &h100040, &h200040, &h300040, &h400040, &h400030, &h400020, &h400010, &h400000, &h401000, &h402000, &h403000, &h404000, &h304000, &h204000, &h104000, &h004000, &h004010, &h004020, &h004030, &h004040, &h003040, &h002040, &h001040, &h202040, &h282040, &h302040, &h382040, &h402040, &h402038, &h402030, &h402028, &h402020, &h402820, &h403020, &h403820, &h404020, &h384020, &h304020, &h284020, &h204020, &h204028, &h204030, &h204038, &h204040, &h203840, &h203040, &h202840, &h2C2C40, &h302C40, &h342C40, &h3C2C40, &h402C40, &h402C3C, &h402C34, &h402C30, &h402C2C, &h40302C, &h40342C, &h403C2C, &h40402C, &h3C402C, &h34402C, &h30402C, &h2C402C, &h2C4030, &h2C4034, &h2C403C, &h2C4040, &h2C3C40, &h2C3440, &h2C3040, &h000000, &h000000, &h000000, &h000000, &h000000, &h000000, &h000000, &h000000, &hFFFFFF}
Dim As Integer ret,r,g,b
r=RGBA_R(clr)
g=RGBA_G(clr)
b=RGBA_B(clr)
If depth=4 Then
Dim As Integer d, c
d=&h000000
c=&hFFFFFF
For i As Integer=0 To 15
d=GetDistanceBetweenColours(clr,plt4(i))
If d<c Then
c=d
ret=i
End If
Next
Elseif depth=8 Then
Dim As Integer d, c
d=&h000000
c=&hFFFFFF
For i As Integer=0 To 255
d=GetDistanceBetweenColours(clr,plt8(i))
If d<c Then
c=d
ret=i+1
End If
Next
Else
ret=clr
End If
Return ret
End Function
Function resize(source As Any Ptr, xScale as Single, yScale As Single)As Any Ptr
Dim As Integer sourcewidth, sourceheight,clr,clr2,clr3,clr4,clr5,clr6,clr7,clr8
ImageInfo(source,sourcewidth,sourceheight)
Var ret=ImageCreate(sourcewidth*xScale,sourceheight*yScale)
For y As Integer=0 To sourceheight
For x As Integer=0 To sourcewidth
clr=Point(x,y,source)
If clr<>0 Then Pset ret,(x*xScale,y*yScale),clr
Next
Next
For y As Integer=0 To sourceheight
For x As Integer=0 To sourcewidth
clr=Point(x,y,source)
clr2=Point(x+1,y,source)
clr3=Point(x,y+1,source)
clr4=Point(x+1,y+1,source)
clr5=Point(x-1,y,source)
clr6=Point(x,y-1,source)
clr7=Point(x+1,y-1,source)
For yi As Integer=0 To yScale
For xi As Integer=0 To xScale
'If clr+clr2+clr3<>0 Then
Pset ret,(x*xScale+xi,y*yScale+yi),clr
'End If
Next
Next
Next
Next
Return ret
End Function
Function MirrorImage(source As Any Ptr,plusx As Integer=0,clr2 As Integer)As Any Ptr
Dim As Integer sourcewidth, sourceheight,clr
ImageInfo(source,sourcewidth,sourceheight)
Var ret=ImageCreate(sourcewidth+plusx,sourceheight)
For y As Integer=0 To sourceheight
For x As Integer=0 To sourcewidth-1
clr=Point(x,y,source)
If clr=clr2 Then
Pset ret,(sourcewidth-x+plusx,y),GetColor(&hFFFFFF)
End If
Next
Next
Return ret
End Function
Function MirrorImage2(source As Any Ptr,plusx As Integer=0,clr2 As Integer,plusy As Integer=0)As Any Ptr
Dim As Integer sourcewidth, sourceheight,clr
ImageInfo(source,sourcewidth,sourceheight)
Var ret=ImageCreate(sourcewidth+plusx,sourceheight+plusy)
For y As Integer=0 To sourceheight
For x As Integer=0 To sourcewidth-1
clr=Point(x,y,source)
If clr=clr2 Then
Pset ret,(sourcewidth-x+plusx,sourceheight-y+plusy),GetColor(&hFFFFFF)
End If
Next
Next
Return ret
End Function

BIN
src/fbfonts/upload/mono.fnt Normal file
View File

Binary file not shown.

BIN
src/fbfonts/upload/sans.fnt Normal file
View File

Binary file not shown.

BIN
src/fbfonts/upload/serif.fnt Normal file
View File

Binary file not shown.

296
src/fbgfxbox.fb.bas Normal file
View File

@ -0,0 +1,296 @@
''
'' FreeBASIC Text Input Box using fbgfx only!
''
'' Alex Barry
'' http://www.mrbarry.com/
''
'' June 24, 2011
''
#define DEBUG 1
Type InputBox
public:
Declare Constructor( byref strId as string )
Declare Destructor()
Declare Sub reset( )
Declare Function getStringId( ) As String
Declare Sub display( focus as integer )
Declare Function getInput( ) As Integer
Declare Sub setCaret( pos as integer )
Declare Sub setCaretBlinkRate( nTimesPerSecond as double = 1.0 )
As Integer x, y
As Integer columns
As String * 1 passwordChar
As Integer isPassword
As String text
As Integer redraw
As Integer paddingX, paddingY
As Uinteger background, foreground, border, caretCol
private:
Declare Sub moveCaretLeft()
Declare Sub moveCaretRight()
As Integer caret
As Integer caretDraw
As Integer textStartAt
As Double caretInterval
As Double caretNextBlink
As String stringId
End Type
ScreenRes 800, 600, 16
Dim Shared As Integer fontWidth, fontHeight
'' Get the default width and height of the font
var w = Width()
fontWidth = 800 / LoWord( w )
fontHeight = 600 / HiWord( w )
Dim clickLock as Integer = 0
Dim txt(0 To 1) As InputBox Ptr = { new InputBox( "Left" ), new InputBox( "Right" ) }
txt(0)->x = 20
txt(0)->y = 20
txt(0)->columns = 50
txt(0)->paddingY = 5
txt(0)->setCaretBlinkRate( 2.5 )
txt(1)->x = 500
txt(1)->y = 20
txt(1)->columns = 30
txt(1)->paddingY = 5
txt(1)->setCaretBlinkRate( 2.5 )
txt(1)->isPassword = 1
locate 10, 1
Print "** Press Esc to quit **"
Print "Font Size: " & fontWidth & "x" & fontHeight
Print
Do
Dim As Integer mx, my, mb
GetMouse( mx, my, , mb )
If ( mb And 1 ) And ( Not clickLock ) Then
For obj As Integer = Lbound( txt ) To Ubound( txt )
Dim ibox As InputBox Ptr = txt(obj)
If ( mx >= ibox->x ) And ( mx <= ibox->x+(fontWidth*ibox->columns)+(ibox->paddingX*2) ) And ( my >= ibox->y ) And ( my <= ibox->y+(fontHeight)+(ibox->paddingY*2) ) Then
If obj > 0 Then
Print "Changing focus to " & ibox->getStringId()
For r As Integer = obj-1 To Lbound( txt ) Step -1
swap txt(r+1), txt(r)
Next r
End If
ibox->redraw = 1
If mx < (ibox->x+ibox->paddingX) Then
ibox->setCaret(0)
Else
var caretPos = fix( (mx-(ibox->x+ibox->paddingX))/fontWidth )
ibox->setCaret( caretPos )
End If
End if
Next Obj
clickLock = 1
ElseIf ( ( mb And 1 ) = 0 ) And clickLock Then
clickLock = 0
End if
if txt(0)->getInput( ) then
print "Input (" & txt(0)->getStringId() & ") : `" & txt(0)->text & "`"
txt(0)->reset()
end if
ScreenLock()
txt(0)->display(1)
For u As Integer = 1 To Ubound( txt )
txt(u)->display(0)
Next u
ScreenUnLock()
sleep 1, 1
Loop Until Multikey( &h1 )
For d As Integer = Lbound( txt ) To Ubound( txt )
Delete txt(d)
Next d
Constructor InputBox( byref strId as string )
this.isPassword = 0
this.passwordChar = "*"
this.paddingX = 2
this.paddingY = 2
this.caretInterval = 1.0
this.background = rgb(255,255,255)
this.foreground = rgb(0,0,0)
this.border = rgb( 100,100,100 )
this.caretCol = rgb( 10,10,10 )
this.stringId = strId
this.reset()
End Constructor
Destructor InputBox()
this.text = ""
this.passwordChar = ""
End Destructor
Sub InputBox.reset()
this.text = ""
this.caret = 0
this.caretDraw = 0
this.textStartAt = 1
this.redraw = 1
End Sub
Function InputBox.getStringId( ) As String
return this.stringId
End Function
Sub InputBox.display( focus as integer )
If focus Then
If (Timer >= this.caretNextBlink) Then
this.caretDraw = Not this.caretDraw
this.caretNextBlink = Timer + this.caretInterval
this.redraw = 1
End If
Else
this.caretDraw = 0
End If
If this.redraw Then
Line (this.x, this.y)-step((this.columns*fontWidth)+(this.paddingX*2), fontHeight+(this.paddingY*2)), this.background, bf
Line (this.x, this.y)-step((this.columns*fontWidth)+(this.paddingX*2), fontHeight+(this.paddingY*2)), this.border, b
Dim showChars as string
showChars = Mid( this.text, this.textStartAt )
If len( showChars ) > this.columns Then showChars = Mid( showChars, 1, this.columns )
If this.isPassword = 1 Then
showChars = String( len( showChars ), this.passwordChar )
End If
Draw String ( this.x+this.paddingX, this.y+this.paddingY ), showChars, this.foreground
If this.caretDraw Then
Line ( this.x+this.paddingX + (this.caret*8) - 1, this.y+(this.paddingY/2) )-( this.x+this.paddingX + (this.caret*8), this.y+fontHeight+(this.paddingY) ), this.caretCol, bf
Else
Line ( this.x+this.paddingX + (this.caret*8) - 1, this.y+(this.paddingY/2) )-( this.x+this.paddingX + (this.caret*8), this.y+fontHeight+(this.paddingY) ), this.background, bf
End If
this.redraw = 0
End If
End Sub
Function InputBox.getInput( ) As Integer
'' Parse text input
Dim a As Integer
Dim i As String
Dim As String splitA, splitB
i = Inkey()
a = Asc( i )
this.redraw = 1
If ( a >= 32 ) And ( a <= 126 ) Then
splitA = Mid( this.text, 1, this.textStartAt+this.caret-1 )
splitB = Mid( this.text, this.textStartAt+this.caret )
this.text = splitA & i & splitB
moveCaretRight( )
ElseIf ( a = 13 ) Then
this.redraw = 0
Return 1
ElseIf ( a = 8 ) Then
If ( len( this.text ) > 0 ) And ( this.textStartAt >= 1 ) Then
splitA = Mid( this.text, 1, this.textStartAt+this.caret-2 )
splitB = Mid( this.text, this.textStartAt+this.caret + 1 )
this.text = splitA & splitB
moveCaretLeft( )
End If
ElseIf ( i = (chr(255)+chr(75)) ) Then '' Left
this.moveCaretLeft( )
ElseIf ( i = (chr(255)+chr(77)) ) Then '' Right
this.moveCaretRight( )
ElseIf ( i = (chr(255)+chr(83)) ) Then '' Delete
If ( len( this.text ) > 0 ) Then
splitA = Mid( this.text, 1, this.textStartAt+this.caret-1 )
splitB = Mid( this.text, this.textStartAt+this.caret + 1 )
this.text = splitA & splitB
End If
ElseIf ( i = (chr(255)+chr(71)) ) Then '' Home
this.textStartAt = 1
this.caret = 0
ElseIf ( i = (chr(255)+chr(79)) ) Then '' End
Dim max As Integer
max = len( this.text ) - this.columns
If max < 1 Then
this.textStartAt = 1
this.setCaret( len( this.text ) )
Else
this.textStartAt = max
this.setCaret( this.columns )
End If
Else
If a > 0 Then
#if DEBUG
Print "Unhandled key: ";
For p As Integer = 1 To Len( i )
print asc( Mid( i, p, 1 ) ) & "+";
Next
Print ""
#endif
End If
this.redraw = 0
End If
Return 0
End Function
Sub InputBox.setCaret( p as integer )
If (p < 0) Then
this.caret = 0
ElseIf pos >= 1 Then
If p > this.columns Then p = this.columns
Dim maxd As Integer
maxd = len( mid( this.text, this.textStartAt, this.columns ) )
If p > maxd Then
this.caret = maxd
Else
this.caret = p
End If
End If
this.caretDraw = 0
this.caretNextBlink = Timer
End Sub
Sub InputBox.setCaretBlinkRate( nTimesPerSecond as double )
this.caretInterval = 1.0/nTimesPerSecond
this.caretNextBlink = Timer
End Sub
Sub InputBox.moveCaretLeft()
If this.caret = 0 Then
this.textStartAt -= 1
If this.textStartAt < 1 Then this.textStartAt = 1
Else
this.caret -= 1
End If
End Sub
Sub InputBox.moveCaretRight()
If this.caret = this.columns Then
this.textStartAt += 1
Dim max As Integer
max = len( this.text ) - this.columns
If max < 1 Then
this.textStartAt = 1
Else
this.textStartAt = max
End If
Else
this.caret += 1
End If
End sub

564
src/fbpaint.fb.bas Normal file
View File

@ -0,0 +1,564 @@
#INCLUDE "fbgfx.bi"
Using FB
Windowtitle "Simple Paint Program"
Screenres 640,480,32
Dim Shared As Integer cmd
cmd = 0 'draw mode default
Dim Shared As Integer btnID 'id of button pressed
Dim Shared As Integer penSize
penSize = 3 'pen size default
Dim Shared As Integer mirror
mirror = 0 'default to no mirror
'fill in pallete with colors
Dim As Ubyte r,g,b
Dim Shared As Uinteger colors(48)
For i As Integer = 0 To 47
Read r,g,b
colors(i) = Rgb(r,g,b)
Next i
Dim Shared As Any Ptr canvas1,canvas2 'displayed image
canvas1 = Imagecreate(640,480,Rgb(255,255,254)) 'save image while screen is being worked on
canvas2 = Imagecreate(640,480,Rgb(255,255,254)) 'saves saved image for UNDO
Dim Shared As Integer mx,my,ox,oy,sx,sy,dx,dy,mb 'mouse variables
Setmouse(0,0,1,1)
Dim Shared As Integer sColor 'id of selected color in palette
sColor = 0 'black pen default palette#0
Dim Shared As Integer mode1, mode2 'fill rectangle, fill circle
Sub update()
Screenlock()
'=============
'draw buttons
'=============
For x As Integer = 0 To 15
If cmd=x Or (mirror = 1 And x = 7) Then
Line (x*40,0)-(x*40+39,20),Rgb(100,100,255),bf
Else
Line (x*40,0)-(x*40+39,20),Rgb(10,10,255),bf
End If
Next x
Draw String (4,8),"DRAW RECT CIRC LINE FILL RUB CLS HMIR UNDO SAVE LOAD PEN .... .... .... QUIT",Rgb(255,255,254)
For i As Integer = 0 To 15
Line (i*40,0)-(i*40+39,20),Rgb(200,200,200),b
Next i
'==================
' draw palette
'==================
For x As Integer = 0 To 39
Line (x*16,464)-(x*16+15,479),colors(x),bf
If x = sColor Or (mirror = 1 And x = 7) Then
Line (x*16,464)-(x*16+15,479) ,Rgb(255,255,254),b
Line (x*16+1,464+1)-(x*16+15-1,479-1) ,Rgb(0,0,0),b
Else
Line (x*16,464)-(x*16+15,479) ,Rgb(0,0,0),b
End If
Next x
Screenunlock()
Sleep 2
End Sub
Sub thickLine(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,size As Integer,c As Uinteger)
Dim As Integer x,y
If x1 = x2 And y1 = y2 Then
Circle (x1, y1), size, c, , , , f
Elseif Abs(x2 - x1) >= Abs(y2 - y1) Then
Dim K As Single = (y2 - y1) / (x2 - x1)
For I As Integer = x1 To x2 Step Sgn(x2 - x1)
x = I
y = K * (I - x1) + y1
Circle (x,y), size, c, , , , f
If mirror = 1 Then
Circle (640-x,y),size,c,,,,f 'for horizontal mirror
End If
Next I
Else
Dim L As Single = (x2 - x1) / (y2 - y1)
For J As Integer = y1 To y2 Step Sgn(y2 - y1)
x = L * (J - y1) + x1
y = J
Circle (x,y), size,c,,,,f
If mirror = 1 Then
Circle (640-x,y),size,c,,,,f 'for horizontal mirror
End If
Next J
End If
End Sub
Sub FloodFill (x As Integer, y As Integer, oldcolour As Integer, newcolour As Integer)
Dim As Integer Ptr p = New Integer[16*1024 * 1024]
Dim As Integer n = 0
Dim As Integer x0, y0
If oldcolour = newcolour Then Exit Sub
p[n] = x
p[n+1] = y
n = n + 2
While n > 0
y0 = p[n-1]
x0 = p[n-2]
n = n - 2
If Point(x0, y0) = oldcolour Then
Pset (x0, y0), newcolour
p[n] = x0
p[n+1] = y0-1
p[n+2] = x0
p[n+3] = y0+1
p[n+4] = x0-1
p[n+5] = y0
p[n+6] = x0+1
p[n+7] = y0
n = n + 8
End If
Wend
Delete p
End Sub
Sub Fill()
FloodFill (mx,my,Point(mx,my),colors(sColor))
update()
'wait for select button release
While mb=1
Getmouse mx,my,,mb
Wend
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub drawRectangle()
Dim As Integer r
Dim As String s
While mb=1
Getmouse mx,my,,mb
If mx<>ox Or my<>oy Then 'mouse has moved so draw erase old draw new
Screenlock()
Put (0,0),canvas1,Trans 'restore screen
'fill rectangle mode?
If mode1 = 1 Then
For i As Integer = oy To my
Line (ox,i)-(mx,i),colors(sColor)
Next i
End If
thickLine(ox,oy,mx,oy,penSize,colors(sColor))
thickLine(mx,oy,mx,my,penSize,colors(sColor))
thickLine(mx,my,ox,my,penSize,colors(sColor))
thickLine(ox,my,ox,oy,penSize,colors(sColor))
Screenunlock()
update()
Sleep 1
End If
Wend
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub drawLine()
Dim As Integer sx,sy
sx = mx
sy = my
While mb=1
Getmouse mx,my,,mb
If mx<>ox Or my<>oy Then 'mouse has moved so draw erase old draw new
Put (0,0),canvas1,Trans 'restore screen
thickLine(sx,sy,mx,my,penSize,colors(sColor)) 'draw line
ox = mx
oy = my
update()
End If
Wend
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub drawPen()
While mb=1
Getmouse mx,my,,mb
If mx<>ox Or my<>oy Then 'mouse has moved so draw erase old draw new
thickLine(ox,oy,mx,my,penSize,colors(sColor)) 'drawline onto screenBuffer
ox = mx
oy = my
update()
End If
Sleep 1
Wend
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub Ellipse(x0 As Integer, Y0 As Integer, X1 As Integer, y1 As Integer, c As Uinteger)
'bresenham circle
'void bresenham_ellipse( x0 As Integer,y0 As Integer, x1 As integer, y1 As integer )
If x0>x1 Then Swap x0,x1
If y0>y1 Then Swap y0,y1
Dim As Integer x,y,a2,b2, S, T,xb,yb,b
b=(y1-y0)/2
b2=b*b
a2=(x1-x0)^2/4
xb=(x0+x1)/2
yb=(y0+y1)/2
x = 0
y = b
S = a2*(1-2*b) + 2*b2
T = b2 - 2*a2*(2*b-1)
If mode2 = 1 Then 'fill ellipse
Line ((xb-x),(yb+y))-((xb-x),(yb-y)),c
Line ((xb+x),(yb+y))-((xb+x),(yb-y)),c
End If
Circle ((xb+x),(yb+y)),3,c,,,,f
Circle ((xb+x),(yb-y)),3,c,,,,f
Circle ((xb-x),(yb+y)),3,c,,,,f
Circle ((xb-x),(yb-y)),3,c,,,,f
Do
If S<0 Then
S += 2*b2*(2*x+3)
T += 4*b2*(x+1)
x+=1
Elseif T<0 Then
S += 2*b2*(2*x+3) - 4*a2*(y-1)
T += 4*b2*(x+1) - 2*a2*(2*y-3)
x+=1
y-=1
Else
S -= 4*a2*(y-1)
T -= 2*a2*(2*y-3)
y-=1
End If
If mode2 = 1 Then 'fill ellipse
Line ((xb-x),(yb+y))-((xb-x),(yb-y)),c
Line ((xb+x),(yb+y))-((xb+x),(yb-y)),c
End If
Circle ((xb+x),(yb+y)),3,c,,,,f
Circle ((xb+x),(yb-y)),3,c,,,,f
Circle ((xb-x),(yb+y)),3,c,,,,f
Circle ((xb-x),(yb-y)),3,c,,,,f
Loop While y>0
End Sub
Sub drawCircle()
Dim As Double r
Dim As Integer x,y,cx,cy
While mb=1
Getmouse mx,my,,mb
If mx<>ox Or my<>oy Then 'mouse has moved so draw erase old draw new
Screenlock()
Put (0,0),canvas1,Trans 'restore screen
Ellipse(ox,oy,mx,my,colors(sColor)) 'draw onto screen
If mirror = 1 Then
Ellipse(640-ox,oy,640-mx,my,colors(sColor))
End If
Screenunlock()
update()
End If
Wend
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub Rubber()
Dim As Double r
Dim As Integer x,y,cx,cy
While mb=1
Getmouse mx,my,,mb
If mx<>ox Or my<>oy Then 'mouse has moved so draw erase old draw new
Line(ox,oy)-(ox+20,oy+20),Rgb(255,255,254),bf 'erase box outline
Line(mx,my)-(mx+20,my+20),Rgb(255,255,254),bf
Line(mx,my)-(mx+20,my+20),Rgb(0,0,0),b 'draw box outline
ox = mx
oy = my
update()
End If
Wend
Line(ox,oy)-(ox+20,oy+20),Rgb(255,255,254),bf 'erase box outline
Put canvas2,(0,0),canvas1,Pset 'canvas2 = canvas1
Get (0,0)-(639,479),canvas1 'canvas1 = screen
End Sub
Sub save()
Dim fileName As String
Locate 20,10
Get (0,0)-(639,479),canvas1 'save into canvas1
Line (60,140)-(560,172),Rgb(255,255,254),bf
Line (60,140)-(560,172),Rgb(1,1,1),b
Line Input "Enter picture name:", fileName
Locate 26,10
Print " ... SAVING"
Bsave filename + ".bmp",canvas1
Put (0,0),canvas1,Pset 'copy to screen
update()
End Sub
Sub load()
Dim fileName As String
Locate 20,10
Line (60,140)-(560,172),Rgb(255,255,254),bf
Line (60,140)-(560,172),Rgb(1,1,1),b
Line Input "Enter picture name:",fileName
Bload filename + ".bmp",canvas1
Put (0,0),canvas1,Pset 'copy to screen
update()
End Sub
Color Rgb(0,0,0),Rgb(255,255,254) 'black ink, white paper
Cls 'executes the color change
update()
Dim As String key
Do
Getmouse mx,my,,mb
ox = mx
oy = my
If mb = 1 Then
'is it over drawing area?
If my>20 And my<480-20 Then
If cmd = 0 Then
drawPen()
End If
If cmd = 1 Then
drawRectangle()
End If
If cmd = 2 Then
drawCircle()
End If
If cmd = 3 Then
drawLine()
End If
If cmd = 4 Then
Fill()
End If
If cmd = 5 Then
Rubber()
End If
End If
'is it over buttons
If my<20 Then
btnID = mx\40
If btnID=1 Then 'set rectangle mode
Get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
Locate 18,2
Print "Release mouse button over fill or not fill icon to select mode"
update()
'drop down rectangle examples
For j As Integer = 0 To 1
Line (44,j*32+23)-(44+31,j*32+31+23),Rgb(255,255,254),bf
Line (44,j*32+23)-(44+31,j*32+31+23),Rgb(1,1,1),b
Line (52,31)-(52+16,31+16),Rgb(1,1,1),b
Line (52,63)-(52+16,63+16),Rgb(1,1,1),bf
Next j
While mb=1
Getmouse mx,my,,mb
Wend
'was it released over shape fill mode?
If mx>44 And mx<75 And my>25 And my<87 Then
mode1 = (Int(my-23)\32)
End If
Put (0,0),canvas1,Pset 'restore screen
update()
End If
If btnID=2 Then 'set rectangle mode
Get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
Locate 18,2
Print "Release mouse button over fill or not fill icon to select mode"
update()
'drop down ellipse examples
For j As Integer = 0 To 1
Line (84,j*32+25)-(84+31,j*32+31+25),Rgb(255,255,254),bf
Line (84,j*32+25)-(84+31,j*32+31+25),Rgb(1,1,1),b
Circle (99,40),10,Rgb(1,1,1)
Circle (99,73),10,Rgb(1,1,1),,,,f
Next j
While mb=1
Getmouse mx,my,,mb
Wend
'was it released over shape fill mode?
If mx>84 And mx<115 And my>25 And my<87 Then
mode2 = (Int(my-23)\32)
End If
Put (0,0),canvas1,Pset 'restore screen
update()
End If
If btnID<6 Then
cmd = btnID
End If
If btnID=6 Then
Color Rgb(1,1,1),Rgb(255,255,254) 'black ink, white paper
Line canvas1,(0,0)-(639,479),Rgb(255,255,254),bf 'clear canvas1
Cls
End If
If btnID=7 Then
mirror = mirror+1
If mirror=2 Then mirror = 0
End If
If btnID=8 Then
Put canvas1,(0,0),canvas2,Pset 'get previous
Put (0,0),canvas1,Pset 'copy to screen
update()
End If
If btnID = 9 Then
save()
update()
'btnID = mode 'reset button ID
End If
If btnID = 10 Then
load()
update()
'btnID = mode 'reset button ID
End If
If btnID = 11 Then 'pen size
Get (0,0)-(639,479),canvas1 'save screen into canvas1 to restore
Locate 8,2
Print "Release mouse button over desired pen size"
update()
'drop down pen examples
For j As Integer = 0 To 3
Line (449,j*23+23)-(449+22,j*23+22+23),Rgb(255,255,254),bf
Line (449,j*23+23)-(449+22,j*23+22+23),Rgb(1,1,1),b
Circle (449+11,j*23+11+23),j*2+1,Rgb(1,1,1),,,,f
Next j
While mb=1
Getmouse mx,my,,mb
Wend
'was it released over pen size?
If mx>454 And mx<476 And my>23 And my<114 Then
penSize = (Int(my-23)\23)*2+1
End If
Put (0,0),canvas1,Pset 'restore screen
update()
End If
'wait for button release
While mb = 1
Getmouse mx,my,,mb
Wend
update()
End If
'is it over pallete?
If my>464 Then
sColor = mx\16
While mb = 1
Getmouse mx,my,,mb
Wend
End If
update()
End If
Loop Until btnID = 15
Imagedestroy(canvas1)
Imagedestroy(canvas2)
'Custom colors
ColorData:
' === microsoft PAINT standard colors ===
Data 0 ,0 , 0 'BLACK
Data 127,127,127 'dark gray
Data 195,195,195 'light gray
Data 255,255,254 'WHITE
Data 136, 0, 21 'red brown
Data 185,122, 87 'brown
Data 237, 28, 36 'red
Data 255,174,201 'pink
Data 255,127, 39 'orange
Data 255,201, 14 'deep yellow gold
Data 255,242, 0 'yellow
Data 239,228,176 'light yellow
Data 34,177, 76 'green
Data 181,230, 29 'lime
Data 0,162,232 'turquoise medium blue
Data 153,217,234 'light blue
Data 63, 72,204 'indigo dark blue
Data 112,146,190 'blue gray
Data 163, 73,164 'purple
Data 200,191,231 'lavenda
'=====================================
Data 255,128,128
Data 255, 0, 0
Data 128, 64, 64
Data 128, 0, 0
Data 255,255,128 'yellow
Data 255,255, 0
Data 255,128, 64 'orange
Data 255,128, 0
Data 128, 64, 0 'brown
Data 128,128, 0
Data 128,255,128 'green
Data 128,255, 0
Data 0,255, 0
Data 0,128, 0
Data 0, 64, 0
Data 128,128, 64
Data 0,255,128
Data 0,255, 64
Data 0,128,128
Data 0,128, 64
Data 0, 64, 64
Data 128,128,128 'gray
Data 128,255,255 'blue
Data 0,255,255
Data 0, 64,128
Data 0, 0,255
Data 0, 0,128
Data 64,128,128
Data 0,128,255
Data 0,128,192
Data 128,128,255
Data 0, 0,160
Data 0, 0, 64
Data 192,192,192 'gray
Data 255,128,192 'red
Data 128,128,192
Data 128, 0, 64
Data 128, 0,128 'purple
Data 64, 0, 64
Data 64, 0,128 'black
Data 255,128,255
Data 255, 0,255
Data 255, 0,128
Data 128, 0,255
Data 64, 0,128
Data 255,255,254 'white

41
src/fbpanel.fb.bas Normal file
View File

@ -0,0 +1,41 @@
locate ,,0
dim as integer oldcolor = color
dim as integer oldwidth = width
width 80, 25
view print 1 to 8
color 0, 7
cls
sleep 2000
view print 17 to 25
color , 7
cls
sleep 2000
locate 25,57
print "press any key to exit...";
sleep 2000
view print 9 to 16
color 7, 1
cls
sleep 2000
locate 13, 40 - (len( "Welcome to FreeBASIC!" ) \ 2)
sleep 2000
print "Welcome to ";
color 15
print "FreeBASIC";
color 7
print "!"
sleep
dim as string clearkey = inkey
width oldwidth and &HFFFF, oldwidth shr 16
color oldcolor and &HFFFF, oldcolor shr 16
view print 1 to oldwidth shr 16
cls
locate ,,1

224
src/fontish.fb.bas Normal file
View File

@ -0,0 +1,224 @@
'============= START FONT BUSINESS ==========================
Function Blur(Byref tim As Uinteger Pointer,rad As Single=2) As Uinteger Pointer
Type p2
As Integer x,y
As Uinteger col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Integer=-ymin To ymax
For x1 As Integer=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
#endmacro
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Uinteger Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As Uinteger Pointer pixel
Dim As Uinteger col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x,_y)
For y As Integer=0 To (_y)-1
For x As Integer=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=type<p2>(x,y,col)
Next x
Next y
Dim As Uinteger averagecolour
Dim As Integer ar,ag,ab
Dim As Integer xmin,xmax,ymin,ymax,inc
For y As Integer=0 To _y-1
For x As Integer=0 To _x-1
average()
NewPoints(x,y).col=averagecolour
Next x
Next y
Imageinfo im,,,,pitch,row
For y As Integer=0 To _y
For x As Integer=0 To _x
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),NewPoints(x,y).col)
Next x
Next y
ImageDestroy tim: tim = 0
Function= im
End Function
Sub drawstring(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,im As Any Pointer=0)
Type D2
As Double x,y
As Uinteger col
End Type
Static As d2 cpt(),XY()
Static As Integer runflag
If runflag=0 Then
Redim XY(64,127)
Redim cpt(1 To 64)
Screenres 10,10
dim as uinteger pointer img
Dim count As Integer
For ch As Integer=1 To 127
img=imagecreate(10,10)
Draw String img,(1,1),Chr(ch)
For x As Integer=1 To 8
For y As Integer=1 To 8
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<D2>(x,y)
End If
Next y
Next x
count=0
imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As D2 c=Type<D2>(xpos,ypos)
Dim As Integer dx=xpos,dy=ypos
For z6 As Integer=1 To Len(text)
Var asci=text[z6-1]
For _x1 As Integer=1 To 64
t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(cpt(_x1).x-size/2,cpt(_x1).y-size/2)-(cpt(_x1).x+size/2,cpt(_x1).y+size/2),cpt(_x1).col,bf
Else
Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).col
End If
End If
Next _x1
dx=dx+8
Next z6
End Sub
Sub init Constructor 'automatic loader
drawstring(0,0,"",0,0)
Screen 0
End Sub
function Colour(im as uinteger pointer,newcol as uinteger,grade as integer) as uinteger pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+4*(_x)
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
dim as integer w,h
Dim As Integer pitch,pitch2
Dim As Any Pointer row,row2
Dim As Uinteger Pointer pixel,pixel2
Dim As Uinteger col
Imageinfo im,w,h,,pitch,row
dim as uinteger pointer temp
temp=imagecreate(w,h)
Imageinfo temp,,,,pitch2,row2
for y as integer=0 to h-1
for x as integer=0 to w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
if v>grade then
ppset2(x,y,newcol)
else
ppset2(x,y,rgb(255,0,255))
end if
next x
next y
return temp
end function
sub FONT(byref myfont as uinteger pointer,fontsize as integer,col as uinteger,grade as integer=190)
Const FIRSTCHAR = 32, LASTCHAR = 127
Const NUMCHARS = (LASTCHAR - FIRSTCHAR) + 1
Dim As ubyte Ptr p
dim as uinteger pointer temp
Dim As Integer i
temp = ImageCreate(NUMCHARS * 8*FontSize, 9*FontSize,rgb(255,0,255))
myfont=ImageCreate(NUMCHARS * 8*FontSize, 9*FontSize,rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,chr(i),rgb(255,255,255),FontSize,temp)
Next i
for n as integer=1 to fontsize-1
temp=blur(temp,1)
next n
temp=Colour(temp,col,grade)
put myfont,(0,0),temp,trans
ImageInfo( myfont,,,,, p )
p[0] = 0
p[1] = FIRSTCHAR
p[2] = LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3 + i - FIRSTCHAR] = 8*FontSize
next i
imagedestroy(temp)
end sub
'=================== END FONTS ========================================
'=========== USAGE ========================
screen 19,32
dim as uinteger pointer customfont
dim as uinteger pointer customfont2
dim as uinteger pointer customfont3
'font choice,size,colour
font customfont,3,rgb(0,200,0)
'You can tweak the last parameter a bit.
'The default is 190
font customfont2,1,rgb(200,200,200),205
font customfont3,4,rgb(0,0,255),210
draw string(50,50),"Custom font",,customfont
draw string(50,200),"Custom font2",,customfont2
draw string(50,300),"Custom font3",,customfont3
draw string(50,400),"Press a key",,customfont
sleep
do
screenlock
cls
draw string(10,200),"Once the fonts are created then",,customfont
draw string(10,300),"they display by Draw string.",,customfont
draw string(10,400),"<ESC> to end",,customfont3
screenunlock
sleep 1,1
loop until inkey=chr(27)

23
src/fonts.fb.bas Normal file
View File

@ -0,0 +1,23 @@
#include once "windows.bi"
'
dim as integer p,res
'
dim progpath as zstring * 512
res=GetModuleFileName(NULL,progpath,512)
'
p=instr(progpath,"\")
while p>0
mid(progpath,p,1)="_"
p=instr(progpath,"\")
wend
'
print "REGEDIT4" '"Windows Registry Editor Version 5.00"
print
print "[HKEY_CURRENT_USER\Console\";progpath;"]"
print !"\"FontSize\"=dword:000e0000" '14 pt
print !"\"FontFamily\"=dword:00000036"
print !"\"FontWeight\"=dword:000002bc" 'bold
print !"\"FaceName\"=\"Lucida Console\""
'print !"\"QuickEdit\"=dword:00000001"
'
sleep

18
src/fonts/demo.bas Normal file
View File

@ -0,0 +1,18 @@
Const Xmax=640
Const Ymax=480
ScreenRes Xmax,Ymax,32
#Include Once "fontlib.bi"
ScreenLock
Line (0,0)-(Xmax,Ymax),RGB(30,30,30),BF
ColorRGB(86,156,214,3)
ColorRGB(86,156,214,4)
DrawString("Hello World! :-) VGA-16",30,10,VGA16)
DrawString("Hello World! :-) VGA-14",30,30,VGA14)
DrawString("Hello World! :-) VGA-8",30,50,VGA8)
DrawString("Hello World! :-) PX Sans Nouveaux",30,70,SANS)
DrawString("Hello World! :-) Monospace",30,90,MONO)
ScreenUnlock
Sleep

BIN
src/fonts/font1.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 41 KiB

3
src/fonts/font1.fon Normal file
View File

@ -0,0 +1,3 @@
font1.bmp
all=8
8

BIN
src/fonts/font2.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 47 KiB

3
src/fonts/font2.fon Normal file
View File

@ -0,0 +1,3 @@
font2.bmp
all=8
8

BIN
src/fonts/font3.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 23 KiB

3
src/fonts/font3.fon Normal file
View File

@ -0,0 +1,3 @@
font3.bmp
all=8
8

97
src/fonts/fontlib.bi Normal file
View File

@ -0,0 +1,97 @@
Type TFont
As String nam,imgpath
As Integer height,charlength(93)
As Any Ptr img,char(93)
End Type
Dim Shared As TFont Font(4)
Dim Shared As UByte num_fonts
Sub LoadFont(nam As String, height As UByte, path As String)
Dim As String length
Dim As Integer count,fontlength
With Font(num_fonts)
.nam=nam
.height=height
.img=ImageCreate(93*8,height)
Var ff=FreeFile
Open path For Input As #ff
Line Input #ff,.imgpath
Line Input #ff,length
For i As Integer=1 To 93
.charlength(i)=Val(Mid(length,5))
Next
Do
Line Input #ff,Length
count+=1
.charlength(count)=Val(Length)
Loop Until Eof(ff)
Close #ff
Bload .imgpath,.img
For i As Integer=1 To 93
.char(i)=ImageCreate(.charlength(i),height)
Get .img,(fontlength,0)-(fontlength+.charlength(i)-1,height-1),.char(i)
fontlength+=.charlength(i)
Next
ImageDestroy .img
End With
num_fonts+=1
End Sub
Const VGA14=0
Const VGA16=1
Const VGA8=2
Const SANS=3
Const MONO=4
LoadFont("VGA_14",14,"font1.fon")
LoadFont("VGA_16",16,"font2.fon")
LoadFont("VGA_8",8,"font3.fon")
LoadFont("Sans Serif 11",11,"sans11.fon")
LoadFont("Monospace 14",15,"mono14.fon")
function replace(byval src as uinteger, byval dest as uinteger, byval p as any ptr) as uinteger
dim c as uinteger = *cptr(uinteger ptr, p)
if src = RGB(255,255,255) then
return c
elseif src = 0 then
return dest
else
return src
end if
end function
Sub ColorRGB(R As UByte, G As UByte, B As Ubyte, fontid As UByte=0)
Dim As ULong C
C=RGB(R,G,B)
For i As Integer=1 To 93
Put Font(fontid).char(i),(0,0),Font(fontid).char(i),Custom,@replace,@c
Next
End Sub
Sub DrawString(text As String, x As Short, y As Short, fontid As UByte=0)
Dim As Integer fontlength
For i As Integer=1 To Len(text)
'Put (x+(i-2)*8+(8-Font(fontid).Charlength(Asc(Mid(text,i,1))-32)),y),Font(fontid).Char(Asc(Mid(text,i,1))-32),Trans
If Mid(text,i,1)<>" " Then
Put (x+fontlength,y),Font(fontid).Char(Asc(Mid(text,i,1))-32),Trans
fontlength+=Font(fontid).Charlength(Asc(Mid(text,i,1))-32)
Else
fontlength+=6
End If
Next
End Sub
Function FontWidth(text As String, fontid As UByte=0)As Integer
Dim As Integer fontlength
For i As Integer=1 To Len(text)
If Mid(text,i,1)<>" " Then
fontlength+=Font(fontid).Charlength(Asc(Mid(text,i,1))-32)
Else
fontlength+=6
End If
Next
Return fontlength
End Function

BIN
src/fonts/fonts.zip Normal file
View File

Binary file not shown.

BIN
src/fonts/mono14.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.5 KiB

3
src/fonts/mono14.fon Normal file
View File

@ -0,0 +1,3 @@
mono14.bmp
all=8
8

BIN
src/fonts/sans11.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 878 B

95
src/fonts/sans11.fon Normal file
View File

@ -0,0 +1,95 @@
sans11.bmp
all=8
2
4
9
6
11
7
2
4
4
6
6
3
4
2
5
6
4
6
6
6
6
6
6
6
6
2
3
4
6
4
6
10
8
7
7
7
7
7
8
7
2
6
7
7
8
7
8
7
8
7
7
8
8
8
10
8
8
7
3
5
3
6
7
3
6
6
6
6
6
5
6
6
2
3
5
2
8
6
6
6
6
5
6
5
6
6
10
6
6
6
4
2
4

5
src/hello.fb.bas Normal file
View File

@ -0,0 +1,5 @@
Cls
Print "Hello, World!"

BIN
src/inkey.fb Executable file
View File

Binary file not shown.

21
src/inkey.fb.bas Executable file
View File

@ -0,0 +1,21 @@
Dim As String key, char
Dim As Integer i
Do
'Check keyboard buffer
key = Inkey
'If key has been pressed
If Len(key) > 0 Then
'Clear the last message
Locate 1, 1
Print Space(79);
'Reposition cursor
locate 1,1
'Print current key codes
For i = 1 To Len(key)
char = Mid(key, i, 1)
Print "Character: ";char; " Code: ";Asc(char); " ";
Next
End If
Sleep 10
Loop Until key = Chr(27)
End

28
src/makdword.fb.bas Normal file
View File

@ -0,0 +1,28 @@
#define MAKDWORD(x,y) (cint(x) shl 16 or cint(y))
Dim myInt As Uinteger
Dim As Integer i, cnt
myInt = MAKDWORD(5,5)
Width 80,25
cnt = 1
For i = 1 to 80
If cnt = 10 Then
cnt = 0
End If
Locate 1, i
Print Str(cnt)
cnt += 1
Next
cnt = 2
For i = 2 To 25
If cnt = 10 then
cnt = 0
End If
Locate i,1
Print Str(cnt);
cnt += 1
Next
Locate Hiword(myInt), Loword(myInt)
Print "We stored the screen location in a single uinteger"
End

48
src/passwdbox.fb.bas Normal file
View File

@ -0,0 +1,48 @@
cls
i = 20
maxchar = 20
screen 12
Do
color 7, 0
cls
locate 2, 1
print "Password:"
color 4,15
' if passed the maximum character limit, then take one
' letter out of the password to make it not pass the limit
if len(pass$) > maxchar then pass$ = mid$(pass$, 1, len(pass$) - 1)
for s = 1 to maxchar
locate 3,s
print " ";
next s
if len(pass$) > 0 then
for s = 1 to len(pass$)
locate 3, s
print "*";
next s
end if
do
a$ = inkey$
loop until a$ <> ""
if a$ = chr$(13) then
cls
color 4, 0
print "You typed "; pass$
sleep
end
end if
if a$ = chr$(8) then
pass$ = left(pass$, len(pass$) - 1)
i=i+1
else
pass$ = pass$ + a$
i=i-1
end if
loop
End

24
src/repeats.fb.bas Normal file
View File

@ -0,0 +1,24 @@
Dim As Single total, count, number
Dim As String text
Print "This program will calculate the sum and average for a"
Print "list of numbers. Enter an empty value to see the results."
Print
Do
Input "Enter a number: ", text
If text = "" Then Exit Do
count += 1
total += Val(text)
Loop
Print
Print "You entered: "; count; " number(s)"
Print "The sum is: "; total
If count > 0 Then Print "The average is: "; total / count
Print
Print "Any keypress ends program.";
Sleep

568
src/screenres.fb.bas Normal file
View File

@ -0,0 +1,568 @@
/' ######################### ABSTRACT ##############################
File: ScreenRes_Width.bas Updated: 2015 Jan 03
Language: FreeBASIC 1.00.0 ( 32bit Windows ) By: Dean Saurdine
Purpose: Demonstrate font sizes in console and GfxLib gui screens
Skillset: beginning Beginner
Notes: 1) No copyright. Public domain. No warranty. Your risk.
2) Coded Courier New 10pt on 72 columns.
3) Ensure -s gui compiler switch is NOT set.
4) The three main program segments can be three different
program files and three different executables, if desired.
5) Appendix follows main program and can be read first, if
desired. Written for the beginning Beginner.
##################################################################### '/
REM####################### MAIN PROGRAM ############################
/' ********************************
***** FreeBASIC console screen *****
********************************
'/
REM setup FreeBASIC console screen
Screen , Rem default FreeBASIC screen
Width 43,28 Rem columns,rows
Color 0,15 Rem black foreground,white background
Cls
REM print box grid at font size
Color ,7 Rem light gray background
For false_loop As Integer = 0 To 0
Dim As Integer row = 0
Dim As Integer column = 0
Rem odd numbered rows
For row = 1 To 27 Step 2
For column = 1 To 43 Step 2
Locate row,column : Print Space(1) ;
Next column
Next row
Rem even numbered rows
For row = 2 To 28 Step 2
For column = 2 To 42 Step 2
Locate row,column : Print Space(1) ;
Next column
Next row
Next false_loop
'Print row Rem try compiling with this line uncommented
/'
Note: the variables false_loop, row and column are visible only while
the false loop runs, which is exactly one time. false_loop, row and
column are created once. This coding technique is efficient for
loop-in-loop with large counters and small steps, a common occurence
when creating "graphic" elements. The expense is the creation of
false_loop, which is a do-nothing variable. Alternatives to a false
loop? Will they obfuscate the code?
Counting "variable creations" can be considered as a first step in
managing the computer's memory space. Programs with well managed memory
space run faster and smoother, and the concept becomes increasingly
important as programs become larger and more complex. More advanced
memory space management methods are beyond this program's purpose.
'/
REM print text
Color ,15 Rem back to white background
'Color ,7 Rem try this for different visual effect
Locate 2,2 : Print "FreeBASIC console font size 8x12 pixels" ;
Locate 5,2 : Print "console 'Print' is opaque background" ;
Locate 10,9 : Print "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ;
Locate 12,9 : Print "abcdefghijklmnopqrstuvwxyz" ;
Locate 14,9 : Print "0 1 2 3 4 5 6 7 8 9 ~_+`-=" ;
Locate 16,9 : Print "!@(#)$[%]^{&}*<?>;':""|,\." ;
Locate 21,9 : Print "press a key to continue..." ; : Sleep
Locate 21,9 : Print " " ;
/' *************************
***** GfxLib gui screen *****
*************************
'/
REM sub definitions
Sub model( ByVal columns As Integer , _ Rem console layer
ByVal rows As Integer , _ Rem console layer
ByVal w As Integer , _ Rem font width in pixels
ByVal h As Integer _ Rem font height in pixels
)
REM set and display the different GfxLib gui screen font sizes
REM finish setup GfxLib gui screen.
'ScreenRes 336,336 Rem graphic layer x,y pixels
Width columns,rows Rem console layer for font size w x h
Color 0,15 Rem black foreground,white background
Cls
/'
Note: window, screen, and layer are different concepts. For now, we can
say "layers on a screen, screen in an operating system window." We can
also say "everything that can be done on the console screen is now done
on the GfxLib gui screen's console layer".
The first mnemomic will eventually become "viewport in a layer, layer on
a page, page on a screen, screen in an operating system window."
Viewports and pages are beyond this program's purpose.
Executing ScreenRes more than once may result in the GfxLib gui screen's
operating system window returning to its original position, if it has
been moved while the executable is running. Try it by uncommenting
ScreenRes in this code block.
'/
REM print text on console layer
Locate 2,2 : Print "GfxLib gui font size 8x" + Str(h) + Space(1) + _
"pixels" ;
REM draw text on graphic layer
Color 32 Rem bright blue foreground
Draw String ( (2-1)*w,(2-1)*h ), "GfxLib gui"
/'
Note: the GfxLib gui screen, as it is set in this program, has an
adjustable 256 color palette, with color index numbers from 0 to 255.
For now, we can say Color 0 and Color 15 are identical to the console
screens. Color 1 through Color 14 may look different. Adjusting the
GfxLib gui screen's color palette is beyond this program's purpose.
The Draw String should precisely overlay the first part of the Print.
The "math" inside the Draw String's outer braces converts a column,row
position to an x,y position, using the following general equations:
x = ( pseudo column - 1 ) * w
y = ( pseudo row - 1 ) * h
Pseudo because real columns and real rows are on the console layer.
The 1 is because the layers have different origin coordinate numbers:
The console layer's origin coordinate numbers are column,row = 1,1.
The graphic layer's origin coordinate numbers are x,y = 0,0.
The two origins are at the same place, which is the GfxLib gui screen's
upper left corner.
The w is because one console layer column is w pixels wide, and the h is
because one console layer row is h pixels high.
Pseudo column and pseudo row do not need to be integers in these
equations. The calculation results will be reduced to the next lower
integer when used for the x and y positions in a drawing command. Try
pseudo column = 2.6, pseudo row = 3.3, or some other fractions.
'/
REM draw box grid at font size on graphic layer
Color 7 Rem light gray foreground
Scope
Dim As Integer y = 0
Dim As Integer x = 0
For y = 0 To (rows-1)*h Step h
For x = 0 To (columns-1)*w Step w
Line (x-1,y-1)-(x+w-1,y+h-1),,B Rem B = hollow Box
Next x
Next y
End Scope
'Print y Rem try compiling with this line uncommented
/'
Note: the Scope...End Scope code block works the same way as a false
loop, and has the advantage of not creating a do-nothing variable.
Alternatives to Scope, without obfuscating the code?
Placement of the grid, for visual effect, depends on the font size
and the physical pixel size and shape. Different "screen" manufacturers
and/or models may have different physical pixel sizes and shapes.
code correct... Line (x,y)-(x+w,y+h),,B
move box one pixel left... Line (x-1,y)-(x+w-1,y+h),,B
then one pixel up... Line (x-1,y-1)-(x+w-1,y+h-1),,B
Remember: "good visual effect" may not always be "code correct".
'/
REM mixed printing and drawing on their respective layers
Color 0 Rem back to black foreground
'Color 0,7 Rem try this for different visual effect
Locate ( 5,2 ) : Print _
"console ""Print"" is opaque background" ;
Draw String ( (2-1)*w,(7-1)*h ), _
"graphic ""Draw"" is transparent background"
Draw String ( (9-1)*w,(10-1)*h ), _
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Draw String ( (9-1)*w,(12-1)*h ), _
"abcdefghijklmnopqrstuvwxyz"
Draw String ( (9-1)*w,(14-1)*h ), _
"0 1 2 3 4 5 6 7 8 9 ~_+`-="
Draw String ( (9-1)*w,(16-1)*h ), _
"!@(#)$[%]^{&}*<?>;':""|,\."
Locate ( 21,9 ) : Print _
"press a key to continue..." ;
Sleep
/'
Note: this coding style shows the coding similarities and differences
between printing text on the console layer and drawing text on the
graphic layer. What are they? Does printing and drawing order matter?
Recall the "math" inside Draw String's outer braces converts column,row
position to x,y position. Can you create general equations to convert
x,y position to column,row position? Where would they be used?
'/
End Sub
REM end of sub definitions
REM main program
REM start setup GfxLib gui screen
ScreenRes 336,336 Rem graphic layer x,y pixels
'Width columns,rows Rem in the sub definition
'Color foreground,background Rem in the sub definition
'Cls Rem in the sub definition
REM set and display the different GfxLib gui screen font sizes
model( 42,42 , 8,8 ) Rem console layer columns,rows for font size w,h
model( 42,24 , 8,14 ) Rem ditto
model( 42,21 , 8,16 ) Rem ditto
'model( 42,28 , 8,12 ) Rem try this illegal font size, with and
Rem without the other models.
REM end of main program
/' *****************************
***** GfxLib console screen *****
*****************************
'/
REM setup GfxLib console screen Rem closes GfxLib gui screen, if open
Screen 0 Rem GfxLib console screen
Width 80,25 Rem default columns,rows
Color 7,0 Rem default foreground,background
Cls
REM print text
Locate 2,2 : Print "GfxLib console font size 8x12 pixels" ;
Locate 21,2 : Print "press a key to end this executable..." ; : Sleep
REM end of main program
REM#####################################################################
REM######################## APPENDIX ###############################
/'
----------
"Graphic screen text is too small" usually means a lack of understanding
of how the GfxLib gui screen works. There is a lot to learn and this is,
fortunately, one of a very few times that interrelated concepts have to
be learned simultaneously.
This program belongs to the category of "study and play with this, then
see me if you have questions". It is written in the FreeBASIC (fb)
dialect of the BASIC coding language.
This appendix and main program's /'Note...'/ are meant to supplement the
existing wiki pages, and have evolved with "can you explain..." and "can
I see your 3-ring binder...". /'Note...'/ can be considered as footnotes
to specific code blocks. My questions and "try this" are meant to
stimulate thinking and creativity.
----------
Prerequisites, or keywords/keyboard keys "you are supposed to know".
Some do not have proper wiki pages as of this appendix's writing.
colon (statement termination = : = CR)
Enter key (statement and line termination = Enter key = CRLF)
underscore (statement continuation = _ = suppress CR in CRLF)
Rem (human readable comment, in the FreeBASIC variations)
Screen , (FreeBASIC console screen)
Width (screen size)
Color (screen Colors)
Cls (Clear the screen)
Locate (position screen cursor)
Print (Print something on screen)
Dim (variable definition)
Integer (variable or expression type)
String (variable or expression type)
Str (create String from number)
Space (flexible, human readable version of " ")
plus (String concatination = +)
Scope...End Scope (code block, localized new variable visibility)
For...Next (code block, looping with built-in counter)
Sub...End Sub (code block, branching)
Sleep (suspend program execution)
New keywords to learn:
ScreenRes x,y (GfxLib gui screen)
Screen 0 (GfxLib console screen)
Draw String (Draw text as String on graphic layer)
Line (draw Line or box on graphic layer)
----------
To be consistent with the corresponding compiler switches, which are
-s gui and -s console, the word "gui" is used to identify what other
coders may call "graphic" screens.
----------
"Terminal 8x12" is the intended font style and size for the console
screen segments of this program.
See my Console_Defaults.bas program for discussion of console screen
default settings (Windows operating system).
----------
Font size can be verified with this program's running executable. There
should be, for font size 8x12, four lines for every three lines of font
size 8x16. Eight lines for every six lines, sixteen for twelve...
"Four for three" is calculated from the Least Common Multiple (LCM) of
12 and 16. LCM is a concept from mathematics.
LCM( 12,16 ) = 48. 48 is the smallest common screen height, in pixels.
Then calculate the corresponding number of available screen rows from:
available rows = LCM / font height
8x12 font size: available rows = 48 / 12 = 4
8x16 font size: available rows = 48 / 16 = 3
----------
GfxLib is one of FreeBASIC's built-in libraries. GfxLib contains the
FreeBASIC gui screens and another FreeBASIC console screen. In this
appendix, the screens accessed via GfxLib are called GfxLib gui screen
and GfxLib console screen, and the default FreeBASIC console screen is
called the FreeBASIC console screen.
The GfxLib console screen can be considered as having the same default
screen settings as the FreeBASIC console screen, and these defaults are
set in the same way (via cmd.exe).
Use the FreeBASIC console screen if your program has no gui elements, as
GfxLib will bloat the executable. Use the GfxLib console screen if, for
any reason, you want to switch from a GfxLib gui screen to a console
screen.
----------
Initiating a GfxLib gui screen with the "Screen mode" statement is from
old BASIC dialects, and should only be used for initial translation of
old BASIC programs. The FreeBASIC way to initiate a GfxLib gui screen is
through the use of the ScreenRes keyword. ScreenRes can be used in a
simple way, as in this program, or ScreenRes can be more capable than
the various gui screens created from "Screen mode".
----------
The GfxLib gui screen can be considered as having one built-in unnamed
fixed-width font, whose style resembles Courier. Most text editors and
word processors set font size in points. GfxLib gui screen's font size
is set in pixels. This font size is represented by a box w pixels wide
and h pixels high. Characters, in the font set, fit into the box.
GfxLib gui screen's available font sizes are 8x8, 8x14 and 8x16. In
words, the available font width is w = 8 pixels and the available font
heights are h = 8, 14 and 16 pixels. The default height is h = 8 pixels.
The size of the GfxLib gui screen's built-in font can be adjusted by the
coder through the use of the "ScreenRes x,y" and "Width columns,rows"
statement pair. Adjusting the size of GfxLib gui screen's built-in font
is a purpose of this program.
The coder can, through advanced use of the ScreenRes keyword, introduce
and use other fonts. The coder can also use other libraries to introduce
and use other fonts (and screens). Other fonts and screens are beyond
this program's purpose.
----------
The following LCM table can be used to "rapid prototype" the GfxLib gui
screen, with built-in font size options to try for a common screen size.
LCM = Least Common Multiple, a concept from mathematics.
+--------------------------------+
LCM | rows ( for gui font 8 x h ) |
+-----------+--------------------------------|
| ScreenRes | | | |
| y | h = 8 | h = 14 | h = 16 |
| pixels | | | |
|============================================|
| 112 | 14 | 8 | 7 |
| 224 | 28 | 16 | 14 |
| 336 | 42 | 24 | 21 |
| 448 | 56 | 32 | 28 |
| 560 | 70 | 40 | 35 |
| 672 | 84 | 48 | 42 |
| 784 | 98 | 56 | 49 |
| 896 | 112 | 64 | 56 |
| 1008 | 126 | 72 | 63 |
| 1120 | 140 | 80 | 70 |
| 1232 | 154 | 88 | 77 |
| 1344 | 168 | 96 | 84 |
|======================+---------------------+
| x | columns |
+----------------------+
Read up for x and columns, for font width w = 8 pixels.
Read down for y and rows, for font height h = 8 or 14 or 16 pixels.
Code as: ScreenRes x,y
Width columns,rows
Example: setup GfxLib gui screen smaller than x,y = 800,600 and at font
size 8x14, using the LCM table.
code as: ScreenRes 784,560
Width 98,40
----------
x,y and columns,rows are calculated from the following equations, which
can also be used "fine tune" the GfxLib gui screen after deciding on a
particular font size:
either: columns = x / 8 and rows = y / h
or: x = columns * 8 and y = rows * h
where: h = 8 or 14 or 16
Code as: ScreenRes x,y
Width columns,rows
All equation elements need to be exactly integers (no fractions), or the
GfxLib gui screen font size may revert to the default 8x8. The available
columns,rows will then become the next lower integers, based on the
GfxLib gui screen's default 8x8 font size and the coder's x,y.
Example: setup GfxLib gui screen smaller than x,y = 800,600 and at font
size 8x14, using the equations.
columns = x / 8 = 800 / 8 = 100 ...all are exactly integers
rows = y / h = 600 / 14 = 42.86 ...fractions! Use rows = 42
then... y = rows * h = 42 * 14 = 588 ...all are exactly integers
code as: ScreenRes 800,588
Width 100,42
----------
Summary of FreeBASIC screen features ( for now... )
+-----------------------------------------------+
FreeBASIC Screens | console | GfxLib gui |
| ( Windows ) | |
+---------------------+===============================================|
| screen initiation | Screen , (FreeBASIC) | ScreenRes x,y |
| | Screen 0 (GfxLib) | |
|---------------------+-------------------------+---------------------|
| screen size | columns,rows | x,y |
|---------------------+-------------------------+---------------------|
| default screen size | set via cmd.exe | not defined |
|---------------------+-------------------------+---------------------|
| font style | set via cmd.exe | similar to Courier |
|---------------------+-------------------------+---------------------|
| font size | set via cmd.exe | adjustable 8x8 |
| | | 8x14 |
| | | 8x16 |
|---------------------+-------------------------+---------------------|
| default font size | set via cmd.exe | 8x8 |
|---------------------+-------------------------+---------------------|
| screen colors | fixed 0 to 15 (cmd.exe) | adjustable 0 to 255 |
|---------------------+-------------------------+---------------------|
| default Color | 7,0 if Color is used. | 15,0 |
| | Set via cmd.exe if | |
| | Color is not used. | |
|---------------------+-------------------------+---------------------|
| layer types | "console" | console |
| | | graphic |
+---------------------------------------------------------------------+
Whether or not "console" exists depends on the point of view you are
comfortable with. "Console" as shown here is consistent with the "layers
on a screen, screen in an operating system window" mnemonic. It is
equally correct to say "FreeBASIC console screens do not have layers".
See my Console_Defaults.bas program for discussion of cmd.exe settings.
----------
The following "code" is copy/paste from my template file, named
template_FreeBASIC.bas and saved as a "read only" file. The file helps
me code in a consistent style, and the file evolves as I learn.
REM setup FreeBASIC console screen
Screen , Rem default FreeBASIC screen
Width 80,25 Rem default columns,rows
Color 7,0 Rem default foreground,background
Cls
REM setup GfxLib gui screen
ScreenRes x,y Rem graphic layer pixels
Width columns,rows Rem console layer for font size w x h
Color 15,0 Rem default foreground,background
Cls
REM setup GfxLib console screen Rem closes GfxLib gui screen, if open
Screen 0 Rem GfxLib console screen
Width 80,25 Rem default columns,rows
Color 7,0 Rem default foreground,background
Cls
Comments are free! In my coding style, comments "to the left" describe
code blocks, while comments "to the right" are like sticky notes.
FreeBASIC code is letter-case insensitive, so I use REM "to the left" to
describe a code block and Rem "to the left" to describe a code block
within a code block.
----------
'/
REM end of appendix
REM#####################################################################
REM end of file

18
src/simplebox.fb.bas Normal file
View File

@ -0,0 +1,18 @@
Screen 13
'Move to (50,50) without drawing
Draw "BM 50,50"
'Set drawing color to 2 (green)
Draw "C2"
'Draw a box
Draw "R50 D30 L50 U30"
'Move inside the box
Draw "BM +1,1"
'Flood fill with color 1 (blue) up to border color 2
Draw "P 1,2"
Sleep

27
src/statics.fb.bas Normal file
View File

@ -0,0 +1,27 @@
Sub StaticSub()
Static cnt As Integer
cnt += 1
Print "In StaticSub "; cnt; " time(s)."
If (cnt = 10) Then
Print "That's the end!"
End If
End Sub
' *** Versus VB5 ***
'Private Sub StaticSub()
' Set cnt As Integer
' cnt = cnt + 1
' Print "In StaticSub" & cnt & " times(s)."
' If cnt = 10 Then
' Print "That's the end!"
' End If
'End Sub
Dim i As Integer
For i = 1 to 10
'Call StaticSub until the loop completes
StaticSub
Next
Sleep
End

55
src/termfont.fb.bas Normal file
View File

@ -0,0 +1,55 @@
'*** ONLY WORKS ON WINDOWS ***
#include "windows.bi"
Dim As HKEY hKey1, hKey2
Dim As DWORD dwDisposition
Dim As Integer fontheight,fontwidth
Dim As DWORD fontFamily = 54
Dim As DWORD fontSize
'valid font heights for Lucida console are
'5, 6, 7, 8, 10, 12, 14, 16, 18, 20, 24, 28, 36, and 72
fontheight = 72 'change this value for a different font size
fontwidth = 0
fontsize=(fontheight*2^16)+fontwidth
Dim As DWORD fontWeight = 700
Dim As String key2
key2 = Command(0)
For x As Integer = 1 To Len(key2)
If Mid$(key2,x,1) = "\" Then
Mid$(key2,x,1)="_"
End If
Next x
Dim As String faceName = "Lucida Console"
RegOpenKeyEx( HKEY_CURRENT_USER, "Console", 0, KEY_ALL_ACCESS, @hKey1 )
RegCreateKeyEx( hKey1, Strptr(key2), 0, null, 0, KEY_ALL_ACCESS, _
null, @hKey2, @dwDisposition )
RegSetValueEx( hKey2, "FaceName", 0, REG_SZ, _
Strptr(faceName), Sizeof(faceName)+2 )
RegSetValueEx( hKey2, "FontFamily", 0, REG_DWORD, _
cast(LPSTR,@fontFamily), Sizeof(DWORD) )
RegSetValueEx( hKey2, "FontSize", 0, REG_DWORD, _
cast(LPSTR,@fontSize), Sizeof(DWORD) )
Print RegSetValueEx( hKey2, "FontWeight", 0, REG_DWORD, _
cast(LPSTR,@fontWeight), Sizeof(DWORD) )
freeconsole()
allocconsole()
color 12,0
width 20,1
Print " Big Red Letters!";
Sleep

139
src/tui.fb.bas Normal file
View File

@ -0,0 +1,139 @@
'' Text user interface example
namespace tui
type window
declare constructor _
( _
new_x as integer = 1, new_y as integer = 1, _
new_w as integer = 20, new_h as integer = 5, _
new_title as string = "" _
)
declare destructor( )
declare sub show( )
'' Title property
declare property title as string
declare property title( new_title as string )
'' Position properties
declare property x as integer
declare property x( new_x as integer )
declare property y as integer
declare property y( new_y as integer )
private:
declare sub redraw( )
declare sub remove( )
declare sub drawtitle( )
dim as string mytitle
dim as integer posx, posy, sizew, sizeh
end type
constructor window _
( _
new_x as integer, new_y as integer, _
new_w as integer, new_h as integer, _
new_title as string _
)
this.posx = new_x
this.posy = new_y
this.sizew = new_w
this.sizeh = new_h
this.mytitle = new_title
if( len( this.mytitle ) = 0 ) then
this.mytitle = "untitled"
end if
end constructor
destructor window( )
color 7, 0
cls
end destructor
property window.title( ) as string
return this.mytitle
end property
property window.title( new_title as string )
this.mytitle = new_title
this.drawtitle( )
end property
property window.x( ) as integer
return this.posx
end property
property window.x( new_x as integer )
this.remove( )
this.posx = new_x
this.redraw( )
end property
property window.y( ) as integer
return this.posy
end property
property window.y( new_y as integer )
this.remove( )
this.posy = new_y
this.redraw( )
end property
sub window.show( )
this.redraw( )
end sub
sub window.drawtitle( )
locate this.posy, this.posx
color 15, 1
print space( this.sizew );
locate this.posy, this.posx + (this.sizew \ 2) - (len( this.mytitle ) \ 2)
print this.mytitle;
end sub
sub window.remove( )
color 0, 0
var spaces = space( this.sizew )
for i as integer = this.posy to this.posy + this.sizeh - 1
locate i, this.posx
print spaces;
next
end sub
sub window.redraw( )
this.drawtitle( )
color 8, 7
var spaces = space( this.sizew )
for i as integer = this.posy + 1 to this.posy + this.sizeh - 1
locate i, this.posx
print spaces;
next
end sub
end namespace
dim win as tui.window = tui.window( 3, 5, 50, 15 )
win.show( )
sleep 2000
win.title = "Window 1"
sleep 2000
win.x = win.x + 10
sleep 2000
win.title = "Window 2"
sleep 2000
win.y = win.y - 2
sleep 2000
locate 25, 1
color 7, 0
print "Press any key...";
sleep

123
src/tuibox.fb.bas Normal file
View File

@ -0,0 +1,123 @@
namespace tui
type window
declare constructor _
( _
new_x as integer = 1, new_y as integer = 1, _
new_w as integer = 20, new_h as integer = 5, _
new_title as string = "" _
)
declare destructor( )
declare sub show( )
'' Title property
declare property title as string
declare property title( new_title as string )
'' Position properties
declare property x as integer
declare property x( new_x as integer )
declare property y as integer
declare property y( new_y as integer )
private:
declare sub redraw( )
declare sub remove( )
declare sub drawtitle( )
dim as string mytitle
dim as integer posx, posy, sizew, sizeh
end type
constructor window _
( _
new_x as integer, new_y as integer, _
new_w as integer, new_h as integer, _
new_title as string _
)
this.posx = new_x
this.posy = new_y
this.sizew = new_w
this.sizeh = new_h
this.mytitle = new_title
if( len( this.mytitle ) = 0 ) then
this.mytitle = "untitled"
end if
end constructor
destructor window( )
color 7, 0
cls
end destructor
property window.title( ) as string
return this.mytitle
end property
property window.title( new_title as string )
this.mytitle = new_title
this.drawtitle( )
end property
property window.x( ) as integer
return this.posx
end property
property window.x( new_x as integer )
this.remove( )
this.posx = new_x
this.redraw( )
end property
property window.y( ) as integer
return this.posy
end property
property window.y( new_y as integer )
this.remove( )
this.posy = new_y
this.redraw( )
end property
sub window.show( )
this.redraw( )
end sub
sub window.drawtitle( )
locate this.posy, this.posx
color 15, 1
print space( this.sizew );
locate this.posy, this.posx + (this.sizew \ 2) - (len( this.mytitle ) \ 2)
print this.mytitle;
end sub
sub window.remove( )
color 0, 0
var spaces = space( this.sizew )
for i as integer = this.posy to this.posy + this.sizeh - 1
locate i, this.posx
print spaces;
next
end sub
sub window.redraw( )
this.drawtitle( )
color 8, 7
var spaces = space( this.sizew )
for i as integer = this.posy + 1 to this.posy + this.sizeh - 1
locate i, this.posx
print spaces;
next
end sub
end namespace
dim win1 as tui.window = tui.window( 3, 5, 50, 15, "Flashcards" )
Cls
'win1.title = "Window 1"
win1.show( )
sleep

76
src/tutorial1.fb.bas Normal file
View File

@ -0,0 +1,76 @@
'From the FreeBASIC.Net tutorial site.
#include "fbgfx.bi"
Using FB
'Put all the vars into a custom type
Type ObjectType
x As Single
y As Single
r As Single
l As Single
u As Single
d As Single
speed As Single
End Type
Dim Shared CircleM As ObjectType
Screen 13,8,2,0 'A 320x200 graphical window
SetMouse 0,0,0 'Hide the mouse cursor
CircleM.x = 150 'Put the circle in the middle
CircleM.y = 90 'Of the window.
CircleM.l = 0
CircleM.r = 0
CircleM.u = 0
CircleM.d = 0
CircleM.speed = 1
Do
Cls 'Refreshes the window, so the circle doesn't "paint"
Circle (CircleM.x,CircleM.y), 10, 15 'Sets new location and shape
If CircleM.speed = 0 Then CircleM.speed = 1
If MultiKey(SC_LEFT) Then CircleM.l = 1:CircleM.r = 0:CircleM.u = 0:CircleM.d = 0
If MultiKey(SC_RIGHT) Then CircleM.r = 1:CircleM.l = 0:CircleM.u = 0:CircleM.d = 0
If MultiKey(SC_UP) Then CircleM.u = 1:CircleM.d = 0:CircleM.l = 0:CircleM.r = 0
If MultiKey(SC_DOWN) Then CircleM.d = 1:CircleM.u = 0:CircleM.l = 0:CircleM.r = 0
If MultiKey(SC_UP) And MultiKey(SC_LEFT) Then CircleM.u = 1:CircleM.l = 1:CircleM.d = 0:CircleM.r = 0
If MultiKey(SC_UP) And MultiKey(SC_RIGHT) Then CircleM.u = 1:CircleM.r = 1:CircleM.d = 0:CircleM.l = 0
If MultiKey(SC_DOWN) And MultiKey(SC_LEFT) Then CircleM.d = 1:CircleM.l = 1:CircleM.u = 0:CircleM.r = 0
If MultiKey(SC_DOWN) And MultiKey(SC_RIGHT) Then CircleM.d = 1:CircleM.r = 1:CircleM.u = 0:CircleM.l = 0
'Listens for activity on named keys, and updates the circle
'Position accordingly.
If CircleM.l = 1 Then
CircleM.x = CircleM.x - CircleM.speed
If CircleM.x < 0 Then CircleM.x = 320
End If
If CircleM.r = 1 Then
CircleM.x = CircleM.x + CircleM.speed
If CircleM.x > 320 Then CircleM.x = 0
End If
If CircleM.u = 1 Then
CircleM.y = CircleM.y - CircleM.speed
If CircleM.y < 0 Then CircleM.y = 200
End If
If CircleM.d = 1 Then
CircleM.y = CircleM.y + CircleM.speed
If CircleM.y > 200 Then CircleM.y = 0
End If
If MultiKey(SC_TAB) Then CircleM.speed = CircleM.speed + 1
If MultiKey(SC_SPACE) Then
CircleM.speed = 0
CircleM.l = 0
CircleM.r = 0
CircleM.u = 0
CircleM.d = 0
End If
Sleep 10, 1 'No delay makes the movement invisible
Loop Until MultiKey(SC_Q) Or MultiKey(SC_ESCAPE) 'Escape or Q to exit

4
src/weights.fb.bas Normal file
View File

@ -0,0 +1,4 @@
Dim As Single lb, kg
Input "Enter a weight in pounds:", lb
kg = lb * 0.454
Print lb; " lb. is equal to ";kg; " kg"

23
src/width.fb.bas Normal file
View File

@ -0,0 +1,23 @@
Dim As Integer consize, rows, cols
'Get the current console size
consize = Width
rows = Hiword(consize)
cols = Loword(consize)
Print "Current Rows =";rows
Print "Current Columns =";cols
Print "Press any key..."
Sleep
Cls
'Resize console if necessary
If rows > 25 Then
Width 80, 25
End If
'Get the new console size
consize = Width
rows = Hiword(consize)
cols = Loword(consize)
Print "New Rows =";rows
Print "New Columns =";cols
Sleep
End