Scrolling Color Boxes

Post your FreeBASIC source, examples, tips and tricks here. Please don’t post code without including an explanation.
Post Reply
Quark
Posts: 474
Joined: May 27, 2011 18:16
Location: Pennsylvania, U.S.
Contact:

Scrolling Color Boxes

Post by Quark »

Scrolling Color Boxes (Demo_ColorScroller01.bas) is a demo in the Simple
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
'==============================================================================

Rev5
Posts: 26
Joined: Jun 04, 2014 22:28
Location: USA

Re: Scrolling Color Boxes

Post by Rev5 »

W o w
I could watch this while listening to binaural beats to find my zen place. You've really taken your idea and ran with it. Your code is so clean and you surprised me with using data to store your explanatory text. Shiny :)
AGS
Posts: 1284
Joined: Sep 25, 2007 0:26
Location: the Netherlands

Re: Scrolling Color Boxes

Post by AGS »

Old school color - cycling lives again :) Here is a link to some more old school color cycling
used in combination with a html 5 canvas
http://www.effectgames.com/demos/canvascycle/?sound=0

Here is a bit of code that mimics mouse - hovering (as in 'perform some action
when the mouse stays in one place during a certain time duration).

It uses the fb graphics library (it stops after 10 hover events at which point you have
to press a a key to stop the demo). Perhaps it could be combined with the box drawing
demo to achieve a tooltip-like effect (by replacing mouse_hover with something more
useful than printing a number like changing color of one or more boxes, showing a text message etc...).

Code: Select all

#include "fbgfx.bi"

sub mouse_hover(byval i as integer)
  screenlock
  print i
  screenunlock
end sub

sub mymain()
  #if __FB_LANG__ = "fb"
  Using FB '' Scan code constants are stored in the FB namespace in lang FB
  #endif

  dim i as integer
  
  ''MOUSE_LIMIT controls the amount of time the mouse has to stay in one place
  ''for the mouse-over effect to execute
  const MOUSE_LIMIT = 0.8

  dim t as double
  dim old_x as integer = 0
  dim old_y as integer = 0
  dim x as integer
  dim y as integer
  dim change as ubyte

  ScreenRes 640, 480, 8

  do
    screenlock
    var result = getmouse(x,y)
    screenunlock
    if (old_x <> x orelse old_y <> y) then
      old_x = x
      old_y = y
      t = timer()
      change = 1
    else
      if (timer() - t >= MOUSE_LIMIT) then
        if (change) then
          i += 1
          mouse_hover(i)
        end if
        old_x = x
        old_y = y
        t = timer()
        ''change can only be changed by moving the mouse
        ''change is used to make sure a mouse-hover 'event'
        ''is not issued when the mouse stays in one place
        ''for a long time 
        change = 0
      end if
    end if
    sleep 1,1
  loop while (i < 10)
  sleep
end sub

mymain()
Quark
Posts: 474
Joined: May 27, 2011 18:16
Location: Pennsylvania, U.S.
Contact:

Re: Scrolling Color Boxes

Post by Quark »

@Rev5

Thanks for your report on Scrolling Color Boxes and I'm pleased that you enjoyed it. Without your input I doubt it would have happened in the form it did. Hope you get around to posting some of your own code for more fun and learning.

@AGS

Am about to download your 'old school' color scroller. Thanks for it -- the more examples the better! As you imply, these ideas can, and should be, re-done by others to extend the possibilities. Also, maybe game-makers can find some relief from chasing the bleeding edge of graphical development by finding new uses for good 'old school'. The 'latest and greatest' is fine, but the 'oldie but goody' is valuable too.
Rev5
Posts: 26
Joined: Jun 04, 2014 22:28
Location: USA

Re: Scrolling Color Boxes

Post by Rev5 »

Quark wrote:Hope you get around to posting some of your own code for more fun and learning.
I'm working on a few modules at the moment for a project of mine. Once I get a handle on things I'll convert it over from debug mode to demo mode and share it.
Rev5
Posts: 26
Joined: Jun 04, 2014 22:28
Location: USA

Re: Scrolling Color Boxes

Post by Rev5 »

AGS wrote:Here is a bit of code that mimics mouse - hovering (as in 'perform some action
when the mouse stays in one place during a certain time duration).
So simple but effective. Thanks for sharing this. I noticed however that when the mouse position was outside the window region getmouse(x,y) returns -1 for both coordinates. I added a check for this into your code so that now checking (change) also requires the x or y coordinates to be anything other than -1.

I would assume that actions triggered by hovering would be relative to coordinates on screen like a rectangle or circle or even a fancy polygon if you're into those. By checking for an out of window mouse position the hover won't go into testing against all those possible regions.

Here's the original bit :

Code: Select all

if (change) then
  i += 1
  mouse_hover(i)
end if
Here's a quick fix preventing unwanted changes when outside the window region :

Code: Select all

if (change) and _
   ((x <> -1) or (y <> -1)) then
  i += 1
  mouse_hover(i)
end if
Post Reply