FB Graphics series. It incorporates the idea of using the viewport to
'talk to the user' (thanks Rev5). I remember an old story by Damon Runyon
about a man looking for favors and he usually succeeded in getting them
because 'a story goes with it'. Well, there is usually a 'story' behind
every program and who would appreciate that more than another programmer?
Anyway, I hope you enjoy this color-filled demo featuring the DRAW command,
and the story that goes with it.
Code: Select all
'================================================================================
' Demo_ColorScroller01.bas by Quark - 07/14
' Using FreeBASIC Compiler - Version 0.90.1 for win32
' Use it freely, modify it freely and any responsibility is yours.
'================================================================================
' Purpose: One of a series of graphics demos using common FreeBasic commands.
' This one scrolls the screen using color array manipulation.
'================================================================================
#lang "fb"
#include "fbgfx.bi"
Using fb
'================================================================================
'Declares
Declare Function RndRange(lo As Integer,hi As Integer) As Integer
Declare Function Chance(hap As Integer) As Integer
Declare Function Round Overload (num As Single)As Single
Declare Sub Drawrect(x1 As Single, y1 As Single, _
rectW As Single, rectH As Single, _
rectC As UInteger, rectF As Byte = 0)
Enum ClrStyle
MultiStyle
Rainstyle
Firestyle
PassionStyle
PlantStyle
SunStyle
NightStyle
End Enum
Dim As ClrStyle curstyle
Declare Sub FillColor(a() As UInteger, cols As Integer, rows As Integer,curstyle As ClrStyle)
Declare Function ColorStyle(curstyle As ClrStyle) As UInteger
Declare Sub ColorDown(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorUp(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorRight(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorLeft(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorHalfDown(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorHalfUp(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorHalfRight(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ColorHalfLeft(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
Declare Sub ViewComment(offset As Integer)
'==============================================================================
'INIT
Randomize Timer
Screenres 800, 600, 32,2 '800x600, 32 depth, 2 pages
Dim As Integer r, g, b, w, h
Screeninfo w,h
Windowtitle "Simple FB Graphics Demo Series"
Dim As Single x1, y1 'for coordinates
Dim As UInteger rcolor
Dim As Integer numColumns = w\40, numRows = h\30 'columns & rows
Dim As UInteger rectColors(1 To numColumns * numRows)
Dim As Integer columnWidth = w\numColumns, rowHeight = h\numRows
Dim As Integer boxWidth = columnWidth-5, boxHeight = rowHeight-5 'box width, height
Dim As Integer cnt, hap, change, utilNum
'==============================================================================
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " THE DRAW COMMAND"
data ""
Data "A lot can be done with this somewhat neglected command in FreeBasic."
data ""
data "In the first demo the DRAW command will be used to fill the screen"
Data "with colored rectangles or 'boxes', each one by DRAW command. The"
Data "frames are there but we have not yet filled the boxes with color."
data ""
Data " (For all the mini-demos, use any key to proceed.)"
data ""
Data ""
Data ""
Data " ...any key to continue to colored box-frames..."
Data "enddata"
ViewComment(4) 'data-to-viewport commentary
'------------------------------------------------------------------------------
'CODE SECTION
'------------------------------------------------------------------------------
Screenset 1,0 'set work & view pages
Color Rgb(0,255,0),Rgb(0,0,0)
Cls
For down As Integer = 0 To h - rowHeight Step rowHeight
For across As Integer = 0 To w - columnWidth Step columnWidth
rcolor = Rgb(RndRange(3,13) * 16,RndRange(3,13) * 16,RndRange(3,13) * 16) 'random color
DrawRect(across+1, down+1 , boxwidth, boxheight, rcolor) 'draw box
Next
Next
ScreenSync : Screencopy
While Len(inkey) : Wend
Sleep
'------------------------------------------------------------------------------
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " ABOUT THE BOXES"
Data ""
Data "These demos use the DrawRect routine which needs to know where to put"
Data "the box, how wide and high it is, and the color of the frame. DrawRect()"
Data "can put the box anywhere and it can be of any size."
Data ""
Data "If the final flag is set to 1, then it will fill the box with the"
Data "assigned color. For the many colors required we add, for future use,"
Data "a color-array large enough to supply each box with a fill color."
Data ""
Data "So, that's what comes next -- let's fill those empty boxes!"
Data ""
Data ""
Data ""
Data " ...any key to color-fill the boxes..."
Data "enddata"
ViewComment(2) 'data-to-viewport commentary
'------------------------------------------------------------------------------
'CODE SECTION
'------------------------------------------------------------------------------
Screenset 1,0 'set work & view pages
Color Rgb(0,255,0),Rgb(0,0,0)
cnt = 1
For down As Integer = 0 To h - rowHeight Step rowHeight
For across As Integer = 0 To w - columnWidth Step columnWidth
rcolor = Rgb(RndRange(3,13) * 16,RndRange(3,13) * 16,RndRange(3,13) * 16)
rectColors(cnt) = rcolor : cnt +=1 ' a way of filling the rectColors() array
DrawRect(across+1, down+1 , boxwidth, boxheight, rcolor, 1) 'draw the box
Next
Next
ScreenSync : Screencopy
While Len(inkey) : Wend
Sleep
'------------------------------------------------------------------------------
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " MOVING THE COLORED BOXES"
Data ""
Data "The DRAW command has made all these boxes, and the colors seem nice,"
Data "but what is the next step? Well, the rectColors() array is filled with"
Data "colors -- could we move them around to get some effect?"
Data ""
Data "What if the rows were all moved down and a new row of colors made for"
Data "the top row? The colors would seem to be moving downward. Sounds"
Data "good, so a new routine called ColorDown() is made. Manipulating the"
Data "color array is very similar to moving things around on the screen."
Data ""
Data "Hmm, might as well create a style for our bright colors and add a"
Data "FillColor() routine to fill the color array whenever desired."
Data ""
Data ""
Data " Unleashing ColorDown() -- let it scroll, er, roll."
Data ""
Data " (Hint: press ALT-ENTER for fullscreen)"
Data ""
data ""
Data ""
Data " ...any key for downward color scrolling..."
Data "enddata"
ViewComment(2) 'data-to-viewport commentary
'------------------------------------------------------------------------------
'CODE SECTION
'------------------------------------------------------------------------------
Screenset 1,0 'set work & view pages
Color Rgb(0,255,0),Rgb(0,0,0)
curstyle = MultiStyle ' 'set style of color styles from ENUM clrstyle
FillColor(rectColors(), numColumns, numRows, curstyle) 'fill rectColors() array
While inkey <> "" : Wend 'clear keyboard-buffer
Do Until inkey <> "" 'main loop
Cls
cnt = 1
For down As Integer = 0 To h - rowHeight Step rowHeight
For across As Integer = 0 To w - columnWidth Step columnWidth
rcolor = rectColors(cnt) : cnt +=1
DrawRect(across+1, down+1 , boxwidth, boxheight, rcolor, 1)
Next
Next
ScreenSync : Screencopy
Sleep 5
'move data down in rectColors()
ColorDown(rectColors(),numColumns, numRows,curstyle)
Loop 'main loop
'------------------------------------------------------------------------------
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " MOVING THE COLORED BOXES IN EIGHT WAYS"
Data ""
Data "Now that last demo was a lot of action for simply tweaking an array --"
Data "the color array. Now what about the other directions like up, left,"
Data "right? OK, we implement those. Would it be interesting to move only"
Data "half of the boxes, meaning every other column or row? Let's have"
Data "those four scrolling color patterns too."
Data ""
Data "This means we add 7 additional routines to the program. The pattern"
Data "is: scroll up, then left, down, right, then the same pattern for the"
Data "'half' routines which only affect boxes in alternate columns or rows."
Data ""
Data "The effect is rather active and a show for those who delight in color"
Data "and lots of it."
Data ""
data ""
Data ""
Data " ...any key to see 8-way scrolling colored boxes..."
Data "enddata"
ViewComment(2) 'data-to-viewport commentary
'------------------------------------------------------------------------------
'CODE SECTION
'------------------------------------------------------------------------------
Screenset 1,0 'set work & view pages
hap = 1 : utilNum = 200
curstyle = MultiStyle ' 'set style of colors from ENUM clrstyle
FillColor(rectColors(), numColumns, numRows, curstyle) 'fill rectColors() array w colors
While inkey <> "" : Wend
Do Until inkey <> "" 'main loop
'draw all boxes
Cls
cnt = 1
For down As Integer = 0 To h - rowHeight Step rowHeight 'for each row
For across As Integer = 0 To w - columnWidth Step columnWidth 'for each column
rcolor = rectColors(cnt) : cnt +=1 'get box color
DrawRect(across + 1, down + 1 , boxWidth, boxHeight, rcolor, 1) 'draw box
Next
Next
ScreenSync : Screencopy 'show all
Sleep 72 'pause
'cycle through box movements (color array manipulation)
hap += 1
If hap > utilNum Then hap = 1
Select Case hap
Case Is <= (utilNum \ 8) * 1
ColorUp(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 2
ColorLeft(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 3
ColorDown(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 4
ColorRight(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 5
ColorHalfUp(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 6
ColorHalfLeft(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 7
ColorHalfDown(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 8
ColorHalfRight(rectColors(),numColumns, numRows,curstyle)
End Select
Loop 'main loop
'------------------------------------------------------------------------------
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " ADDING COLOR STYLES TO THE SCROLLING BOXES"
Data ""
Data "We have already used a style called MultiStyle to fill the boxes with"
Data "bright colors. A routine called ColorStyle() called with more names"
Data "like RainStyle, FireStyle, PlantStyle and so on gives a variety of"
Data "colors in a given range. Different emotions associate with different"
Data "colors, so we can enjoy them for their affect."
Data ""
Data "Coming up is the same changing scrolling patterns you have just seen,"
Data "but with random changes in the color 'style' as time goes on."
Data ""
data ""
Data ""
Data " ...any key to see scrolling with different color styles..."
Data "enddata"
ViewComment(2) 'data-to-viewport commentary
'------------------------------------------------------------------------------
'CODE SECTION
'------------------------------------------------------------------------------
Screenset 1,0 'set work & view pages
curstyle = MultiStyle 'set style of colors from ENUM clrstyle
FillColor(rectColors(), numColumns, numRows, curstyle)
hap = 1 : change = 1 : utilNum = 200
While inkey <> "" : Wend
Do Until inkey <> "" 'main loop
'draw all boxes
Cls
cnt = 1
For down As Integer = 0 To h - rowHeight Step rowHeight 'for each row
For across As Integer = 0 To w - columnWidth Step columnWidth 'for each column
rcolor = rectColors(cnt) : cnt +=1 'get box color
DrawRect(across + 1, down + 1 , boxWidth, boxHeight, rcolor, 1) 'draw box
'change color style based on chance
If Chance(150) Then
If Chance(150) Then
change = RndRange(1,7)
Select Case change
Case 1
curstyle = MultiStyle
Case 2
curstyle = RainStyle
Case 3
curstyle = FireStyle
Case 4
curstyle = PassionStyle
Case 5
curstyle = PlantStyle
Case 6
curstyle = SunStyle
Case 7
curstyle = NightStyle
End Select
'fill rectColors() array with current 'style' colors
FillColor(rectColors(), numColumns, numRows, curstyle)
End If
End If
Next
Next
ScreenSync : Screencopy 'show all
Sleep 72 'pause
'cycle through box movements (color array manipulation)
hap += 1
If hap > utilNum Then hap = 1
Select Case hap
Case Is <= (utilNum \ 8) * 1
ColorUp(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 2
ColorLeft(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 3
ColorDown(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 4
ColorRight(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 5
ColorHalfUp(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 6
ColorHalfLeft(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 7
ColorHalfDown(rectColors(),numColumns, numRows,curstyle)
Case Is <= (utilNum \ 8) * 8
ColorHalfRight(rectColors(),numColumns, numRows,curstyle)
End Select
Loop 'main loop
'------------------------------------------------------------------------------
' COMMENT SECTION
'------------------------------------------------------------------------------
data ""
Data " FINAL THOUGHTS"
Data ""
Data "All these effects are based on simple graphics commands built in to"
Data "FreeBasic. And probably you have seen great effects in other demos."
Data "To be sure, advanced libraries can do even more, but it is amazing"
Data "what can be done with the basic commands."
Data ""
Data "All these mini-demos depended on the DRAW command, the manipulation"
Data "of the rectColors() array, the ENUM type, and the ability to"
Data "dynamically alter the colors -- all built-in stuff."
Data ""
Data "It is a pleasure for me to try to make interesting things out of"
Data "simple things, and I'm learning a lot too."
Data ""
data ""
Data ""
Data " ... any key to end the program (and thanks for watching)..."
Data "enddata"
ViewComment(3) 'data-to-viewport commentary
End
'==============================================================================
Function RndRange(lo As Integer,hi As Integer) As Integer
'Returns random number in a range, e.g. given range of
'5 and 10 returns a num in range 5,6,7,8,9,10
Return Int(Rnd(1)*(hi-lo+1)+lo)
End Function
'==============================================================================
Function Chance(hap As Integer = 2) As Integer
'Chance of 1 in hap chances, e.g. given 3 it
'returns -1 (True) if 3 and False (0) if 1 or 2
Return Int(Rnd * hap + 1) = hap
End Function
'==============================================================================
Function ColorStyle(curstyle As ClrStyle = MultiStyle) As Uinteger
' GENERATE COLORS FOR GIVEN 'STYLE'
Dim rcolor As UInteger
Select Case curstyle
Case MultiStyle
rcolor = Rgb(RndRange(3,13) * 16 - 1,RndRange(3,13) * 16 - 1,RndRange(3,13) * 16 - 1)
Case RainStyle
rcolor = Rgb(RndRange(2,5) * 16 - 1,RndRange(5,10) * 16 - 1,RndRange(13,14) * 16 - 1)
Case FireStyle
rcolor = Rgb(RndRange(9,14) * 16 - 1,RndRange(2,6) * 16 - 1,RndRange(1,5) * 16 - 1)
Case PassionStyle
rcolor = Rgb(RndRange(9,13) * 16 - 1, RndRange(1,5) * 16 - 1, RndRange(9,13) * 16 - 1)
Case PlantStyle
rcolor = Rgb(RndRange(1,4) * 16 - 1,RndRange(9,14) * 16 - 1,RndRange(2,6) * 16 - 1)
Case SunStyle
rcolor = Rgb(RndRange(8,12) * 16 - 1,RndRange(9,14) * 16 - 1,RndRange(1,4) * 16 - 1)
Case NightStyle
rcolor = RndRange(1,16) * 16 - 1
rcolor = Rgb(rcolor,rcolor,rcolor)
End Select
Return rcolor
End Function
'==============================================================================
Sub FillColor(a() As Uinteger, cols As Integer, rows As Integer,curstyle As ClrStyle)
' FILL BOX-COLOR ARRAY WITH COLORS OF GIVEN 'STYLE'
Dim As Integer Length = Ubound(a)
For r As Integer = 1 To Length Step cols
For c As Integer = r To r + cols - 1
a(c) = ColorStyle(curstyle)
Next
Next
End Sub
'==============================================================================
Sub Drawrect(x1 As Single, y1 As Single, _
rectW As Single, rectH As Single, _
rectC As Uinteger, rectF As Byte = 0)
'DRAW box
Dim As Single newangle = 0
Dim As UInteger newrectC
Color rectC ' set color
Draw "BM" & Str(x1) & "," & Str(y1) ' set location
newangle += 180 : newangle Mod= 360
Draw "TA" & Str(newangle)
Draw "U" & Str(rectH)
newangle += 90 : newangle Mod= 360
Draw "TA" & Str(newangle)
Draw "U" & Str(rectW)
newangle += 90 : newangle Mod= 360
Draw "TA" & Str(newangle)
Draw "U" & Str(rectH)
newangle += 90 : newangle Mod= 360
Draw "TA" & Str(newangle)
Draw "U" & Str(rectW)
If rectF Then 'if flag then fill box with same color as border
newangle += 135 : newangle Mod= 360
Draw "TA" & Str(newangle)
Draw "BU" & Str(1)
Draw "P " & Str(rectC) & "," & Str(rectC) ' fill command
End If
End Sub
'==============================================================================
Sub ColorDown(a() As UInteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move data down in color array
Dim rcolor As Uinteger
For rpos As Integer = cols * rows To cols * 2 Step -cols
For columnNum As Integer = rpos To rpos - (cols - 1) Step -1
a(columnNum) = a(columnNum-cols)
Next
Next
'new colors in top line
For i As Integer = 1 To cols
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorUp(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move data up in color array
Dim rcolor As UInteger
For rpos As Integer = cols To cols * (rows - 1) Step cols
For columnNum As Integer = rpos To rpos - (cols - 1) Step -1
a(columnNum) = a(columnNum+cols)
Next
Next
'new colors in bottom line
For i As Integer = cols * rows - (cols - 1) To (cols * rows)
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorRight(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move data right in color array
Dim rcolor As Uinteger
For rpos As Integer = cols To cols * rows Step cols
For columnNum As Integer = rpos To rpos - (cols - 2 ) Step -1
a(columnNum) = a(columnNum-1)
Next
Next
'new colors in leftmost line
For i As Integer = 1 To (cols * rows) - cols + 1 Step cols
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorLeft(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move data left in color array
Dim rcolor As UInteger
For rpos As Integer = 1 To cols * rows - cols + 1 Step cols
For columnNum As Integer = rpos To rpos + cols - 2
a(columnNum) = a(columnNum + 1)
Next
Next
'new colors in rightmost line
For i As Integer = cols To (cols * rows) Step cols
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorHalfUp(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move data up in color array
Dim rcolor As Uinteger
For rpos As Integer = cols To cols * (rows - 1) Step cols
For columnNum As Integer = rpos + 1 To rpos - (cols - 2) Step -2
a(columnNum) = a(columnNum+cols)
Next
Next
'new colors in bottom line
For i As Integer = cols * rows - (cols - 1) To (cols * rows) - 1 Step 2
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorHalfDown(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move half of data down in color array
Dim rcolor As UInteger
For rpos As Integer = cols * rows To cols * 2 Step -cols
For columnNum As Integer = rpos To rpos - (cols - 1) Step -2
a(columnNum) = a(columnNum-cols)
Next
Next
'new colors in top line
For i As Integer = 2 To cols Step 2
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorHalfRight(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move half of data right in color array
Dim rcolor As Uinteger
For rpos As Integer = cols To cols * rows Step cols * 2
For columnNum As Integer = rpos To rpos - (cols - 2 ) Step -1
a(columnNum) = a(columnNum-1)
Next
Next
'new colors in half of leftmost line
For i As Integer = 1 To (cols * rows) - cols + 1 Step cols * 2
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ColorHalfLeft(a() As Uinteger, cols As Integer, rows As Integer, curstyle As ClrStyle)
'move half of data left in color array
Dim rcolor As UInteger
For rpos As Integer = 1 To cols * rows - cols + 1 Step cols * 2
For columnNum As Integer = rpos To rpos + cols - 2
a(columnNum) = a(columnNum + 1)
Next
Next
'new colors in half of rightmost line
For i As Integer = cols To (cols * rows) Step cols * 2
rcolor = ColorStyle(curstyle)
a(i) = rcolor
Next
End Sub
'==============================================================================
Sub ViewComment(offset As Integer)
'For comment to user: create viewport, read strings, print them
'uses 8 x 16 chars for easier reading
Color Rgb(128,128,128),Rgb(10,0,10)
Dim As Integer w,h, scrdiv = 8 : Screeninfo w, h
Screenset
Width w\8,h\16
View (w\scrdiv,h\scrdiv)-((w\scrdiv)*(scrdiv-1),(h\scrdiv)*(scrdiv-1)), Rgb(0,0,32), Rgb(255,0,0)
Dim As Integer col,row = 16, xcenter = (w\2) - (w\scrdiv)
Dim As String text
'control printing: offset = blank chars before text
col = offset * 8
Cls
Do
Read text : If text = "enddata" Then Exit Do
Draw String (col,row), text, Rgb(0,255,0)
row += 16
Loop
While Len(inkey) : Wend
Sleep
View 'reset viewport to fullscreen
End Sub
'==============================================================================
Function Round(x As Single)As Single
If frac(x)<.5 Then
x=Fix(x)
Else
x=Fix(x+1)
End If
If x = -0 Then x = Abs(x)
Return x
End Function
'==============================================================================