BINARY - Clock "for coder's only" ;-)

User projects written in or related to FreeBASIC.
MrSwiss
Posts: 3726
Joined: Jun 02, 2013 9:27
Location: Switzerland

BINARY - Clock "for coder's only" ;-)

Postby MrSwiss » Jul 24, 2015 11:25

Hi all,
just finished my latest project ... a BIN clock ...

It just happens to coincide with the currently ongoing community discussion on BOOLEAN Type in FB (by coderJeff).
Reference: http://www.freebasic.net/forum/viewtopic.php?f=17&t=23786&start=15
Some Long's in the code are 'misused' as BOOLEANS, see comments in code ...

BTW: our Server: r2-dallas went down whilst I've been writing this post! (obviously it's back up again ...)
Thanks to the Support People at Site5 ...

BIN-Clock.bas:

Code: Select all

' =================================================================== '
' BINARY Clock (incl. Digital & Help) 'MrSwiss  made'™ Version is:
' newly coded, commented and tested: (details below)
' ------------------------------------------------------------------- '
' Copyright © 2015, MrSwiss
' ALL RIGHTS RESERVED! NO COMMERCIAL/EDUCATIONAL USE WHATSOEVER! THIS
' INCLUDES ANY FORM OF DISTRIBUTION IN ANY FORM AND BY ANY MEANS!
' NO WARRANTIES AT ALL ANYWHWERE IN THE WORLD! THE USER TAKES ANY AND
' ALL RISKS! THE AUTHOR DISCLAIMS ANY RESPONSIBILITY FOR ANY TYPE OF
' DAMAGE(S) CAUSED BY THIS CODE! IF IN DOUBT, DON'T USE IT AT ALL!
' FREE FOR PERSONAL, NONPROFIT USE ONLY. GOVERNMENTS: NOT PERMITTED!
' -------------------------------------------------------------------- '
' PLAIN TEXT: Don't LIKE it, don't USE it! It's as simple as that.
' =================================================================== '
' TESTED: with FreeBASIC Compiler Ver. 1.03.0, 32bit and 64bit (WIN)
' COMPILE WITH:  -s gui  (compiler switch), see manual for details
' COMPILER LANGUAGE: "fb" (only, no support for deprecated options!)
' ------------------------------------------------------------------- '
' CREDITS GO TO:   fxm (explanations of calling Bload etc.)
' FB-Forum Topic:   Programming/General/Freebasic 1.03 problems ...
' http://www.freebasic.net/forum/viewtopic.php?f=3&t=23728#p209888
' =================================================================== '

' define screen properties
ScreenRes 400, 200, 32               ' screen setup (32 bit depth, single buffer)
' declarations used by local procedures
Dim As Long PX(5), PY(2), bi(5)         ' C-style arrays: PX(0 To 5), PY(0 to 2), bi(0 To 5)
' bi() an array of 'Long' forced to behave as 'BOOLEAN', see ConvToBIN & PaintTime Sub's
Dim As Long hh, mm, ss, ret            ' var's for time & returned (error) codes (ret should be BOOLEAN too)
Dim Shared As UByte r=0, g=0, b=0, a=255' default color (black), opaque (can be used everywhere)
Dim As String TStr                  ' time string
' declares ... general init stuff
Dim As Any Ptr dclock = ImageCreate(300, 50, , 32)   ' create 'clock face' buffer
ret = Bload (ExePath & "\DigiIF.bmp", dclock)' fill the buffer with the .BMP Graphic (from file)
If ret Then                        ' file NOT found, inform user and quit ...
   ' remember: background, at this point in time is still black ... default
   Draw String (20, 80), "'DigiIF.bmp' NOT found, aborting ...", rgb(255,127,0)   ' orange
   Draw String (20,100), "Press any key to exit program!", rgb(255,127,0)         ' orange
   ImageDestroy dclock               ' destroy image buffer
   Sleep : End 1                  ' quit with errorcode 1 (for batch processing)
EndIf
Color rgba(r,g,b,a), rgba(255,255,255,a)' black on white BG
' initialize the arrays PX, PY (without typing too much), defines _
' the Paint 'Axis-Points' (x, y) used later by 'PaintTime' Sub
For i As Long = 0 To 5
   PX(i) = 105 + i*50               ' the 105 is the x-starting point (80+25) _
Next                           ' + i*50 is the increment by 50
For i As Long = 0 To 2
   PY(i) = 50 + i*50               ' the 50 is the y-starting point (25+25) _
Next                           ' + i*50 is the increment by 50

' ----- local procedures ----- '
Sub GetTime(ByRef hh As Long, ByRef mm As Long, ByRef ss As Long, ByRef TStr As String)
   TStr = Time                     ' get time as string "hh:mm:ss", system time
   hh = ValInt(Left(TStr, 2))         ' ValInt returns a Long = Int<32>
   mm = ValInt(Mid(TStr, 4, 2))      ' ATTN.: ValLng returns a LongInt = Int<64>
   ss = ValInt(Right(TStr, 2))
End Sub


Sub ConvToBIN(ByVal Num As Long, bi() As Long)
   ' reset array to 0 (all positions) to have a defined start ...
   For i As Long = 0 To 5 : bi(i) = 0 : Next   ' single line 'For ... Next' loop
   ' we now only have to set the 'proper' bits (no error checks)
   If Num >= 32 Then               ' max. is 59 Min/Sec (max. 6 bits)
      bi(0) = 1 : Num mod= 32         ' set bi() and get/set the 'remainder'
   EndIf
   If Num >= 16 Then bi(1) = 1 : Num mod= 16 : EndIf   ' single line version (of above)
   If Num >= 8    Then bi(2) = 1 : Num mod= 8  : EndIf   ' if we had BOOLEANS: bi(n) = TRUE
   If Num >= 4  Then bi(3) = 1 : Num mod= 4  : EndIf
   If Num >= 2  Then bi(4) = 1 : Num mod= 2  : EndIf
   If Num   = 1  Then bi(5) = 1
End Sub


Sub PaintTime(ByVal idx As Long, PX() As Long, PY() As Long, bi() As Long)
   For j As Long = 0 To 5            ' we have to always paint 6 fields (hh, mm, ss)
      Select Case As Const idx      ' hh: idx = 0, mm: idx = 1, ss: idx = 2 _
         Case 0                  ' there is, with every call, always only a 1/3 of the code run
            Select Case As Const j   ' every bi() instance once (0 --> 5), MS-Bit first ...
               Case 0            ' this one is special to hh only (5 bits do the trick), 23 = max.
                  Paint (PX(j), PY(idx)), rgba(255,223,0,a), rgba(r,g,b,a)      ' dark yellow
                  Draw String (PX(j)-12, PY(idx)-8), "NOT", rgba(r,g,b,a)         ' default (black)
                  Draw String (PX(j)-16, PY(idx)+1), "used", rgba(r,g,b,a)
               Case 1
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)      ' red (active)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)   ' dark grey (inactive)
                  EndIf
               Case 2
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 3
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 4
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 5
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
            End Select
         Case 1
            Select Case As Const j
               Case 0
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 1
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 2
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 3
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 4
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 5
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
            End Select
         Case 2
            Select Case As Const j
               Case 0
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 1
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 2
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 3
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 4
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
               Case 5
                  If bi(j) Then
                     Paint (PX(j), PY(idx)), rgba(255,0,0,a), rgba(r,g,b,a)
                  Else
                     Paint (PX(j), PY(idx)), rgba(63,63,63,127), rgba(r,g,b,a)
                  EndIf
            End Select
      End Select
   Next
End Sub
' ----- end local procedures ----- '

' ===== MAIN ===== '
Dim As String Title = "Binary - Clock, MrSwiss made(TM)"   ' define 'local var's' to main
Dim As String Help  = "0/32  0/16   0/8   0/4    0/2   0/1"   ' show binary 'weight' of digit
WindowTitle "BINARY - Clock"               ' instead of "BIN-Clock", the .EXE name ...

Do
   If Time = TStr Then Goto wait4TimeChange   ' sleep until second increments
   CLS                                 ' clear screen buffer
   GetTime(hh, mm, ss, TStr)               ' once a second: get new values 24h, aka 'system time'
   ScreenLock
   'Paint (0, 0), rgba(255,255,191,127)         ' paint BG bright yellow, to 'see' the loaded graphics
   Put (80, 25), dclock, Pset               ' graphic for the hour(s)
   Put (80, 75), dclock, Pset               ' graphic for the minute(s)
   Put (80,125), dclock, Pset               ' graphic for the second(s)
   For i As Long = 0 To 2                  ' the outlines/contours filling routine ...
      Select Case As Const i
         Case 0
            ConvToBIN(hh, bi())            ' get BINARY for hours: hh (reset, then fill bi() array)
            PaintTime(i, PX(), PY(), bi())   ' 'Paint' the graphics accordingly (uses all three arrays)
         Case 1
            ConvToBIN(mm, bi())
            PaintTime(i, PX(), PY(), bi())
         Case 2
            ConvToBIN(ss, bi())
            PaintTime(i, PX(), PY(), bi())
      End Select
   Next
   ' dynamically centered string on the .BMP (80+150 pixels = center of graphic [300 x 50 px])
   Draw String (230-((Len(Title)+1)\2)*8, 13), Title, rgba(0,63,191,a)   ' blue color
   Draw String (10, 45), "Hour..: ", rgba(r,g,b,a)      ' default color, absolute positioning
   Draw String (90, 72), Help, rgba(r,g,b,a)         ' display calculation help (bit-weight)
   Draw String (10, 95), "Minute: ", rgba(r,g,b,a)
   Draw String (90, 122), Help, rgba(r,g,b,a)
   Draw String (10, 145), "Second: ", rgba(r,g,b,a)
   Draw String (230-((Len(TStr)+1)\2)*8, 180), TStr, rgba(0,63,191,a)   ' blue: Time-String, dyn. centered
   ScreenUnLock
wait4TimeChange:
   Sleep 200, 1
Loop Until InKey = Chr(255)+"k"               ' top/right X clicked ... quit prog.

ImageDestroy dclock                        ' free allocated ressources (image buffer)

End 0                                 ' End closes prog. [errorcode=0], NO error

This code is a typical case of: re-usability = NONE
Focus on 'Job at hand' = YES, ABSOLUTELY (and only that, see above)

[Obsolete]I still don't know how to properly supply the needed *.bmp file, because my available Host is always asking for PWD?
Any suggestions on permissions etc.???[/Obsolete]

[Edit]try this LINK to my OneDrive shared stuff:
http://1drv.ms/1IqOzKA
hope it works ... you should be able to download right away[/Edit]
D.J.Peters
Posts: 8210
Joined: May 28, 2005 3:28
Contact:

Re: BINARY - Clock "for coder's only" ;-)

Postby D.J.Peters » Jul 24, 2015 22:36

Code: Select all

function BinTime(t as string,n as integer) as string
  var b = bin((t[n]-48)*10+(t[n+1]-48),6)
  select case as const n
  case 0 : return " H: " & b
  case 3 : return " M: " & b
  case 6 : return " S: " & b
  end select
end function

sub UpdateTime(t as string)
  cls : ?
  ? BinTime(t,0) : ?
  ? BinTime(t,3) : ?
  ? BinTime(t,6) : ?
  ? "  " & t
end sub

screenres 11*8,9*8,,,8
dim as string * 8 oldTime
while inkey()=""
  dim as string * 8 nowTime = Time()
  if nowTime<>oldTime then
    UpdateTime nowTime
    oldTime=nowTime
  end if
  sleep 250,1
wend
MrSwiss
Posts: 3726
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: BINARY - Clock "for coder's only" ;-)

Postby MrSwiss » Aug 03, 2015 19:39

Hi all,

the second version of the Digi-Clock:
    smaller DigiIFsq.bmp, 50 x 50px, used 17 times
    recoded procedures
    added error checking (file load)
    compiler decided Window Title (intrinsic defines used)
The link to the needed BMP: http://1drv.ms/1DloGKq

The code (DIGI-Clock.bas) below:

Code: Select all

' ================================================================== '
' BINARY Clock (incl. Digital & Help) 'MrSwiss  made'™ Version is:
' 2.0 = recoded, commented and tested: (details below)
' ------------------------------------------------------------------ '
' Copyright © 2015, MrSwiss
' ALL RIGHTS RESERVED! NO COMMERCIAL/EDUCATIONAL USE WHATSOEVER! THIS
' INCLUDES ANY FORM OF DISTRIBUTION IN ANY FORM AND BY ANY MEANS!
' NO WARRANTIES AT ALL ANYWHWERE IN THE WORLD! THE USER TAKES ANY AND
' ALL RISKS! THE AUTHOR DISCLAIMS ANY RESPONSIBILITY FOR ANY TYPE OF
' DAMAGE(S) CAUSED BY THIS CODE! IF IN DOUBT, DON'T USE IT AT ALL!
' FREE FOR PERSONAL, NONPROFIT USE ONLY. GOVERNMENTS: NOT PERMITTED!
' ------------------------------------------------------------------ '
' PLAIN TEXT: Don't LIKE it, don't USE it! It's as simple as that.
' ================================================================== '
' TESTED: with FreeBASIC Compiler Ver. 1.03.0, 32bit and 64bit (WIN)
' COMPILE WITH:  -s gui  (compiler switch), see manual for details
' COMPILER LANGUAGE: "fb" (only, no support for deprecated options!)
' ------------------------------------------------------------------ '
' CREDITS GO TO:   no contributors
'                idea and coding & graphics by MrSwiss
' ================================================================== '

ScreenRes 400, 200, 32               ' screen setup: width, height, bit depth

Dim Shared As Long PX(5), PY(2), bi(5)   ' global access to arrays
Dim As Long      hh, mm, ss, res
Dim As UByte   r=0, g=0, b=0, a=255   ' default color = black, opaque
Dim As String   TStr

Dim As Any Ptr dclock = ImageCreate(50, 50,, 32)' create 'clock face' buffer
res = Bload (ExePath & "\DigiIFsq.bmp", dclock)   ' fill the buffer with the .BMP Graphic
If res Then                        ' if .bmp not found, inform user and quit
   Draw String (55, 88), "DigiIFsq.bmp not found, aborting ...", rgb(255,95,95)
   Draw String (55,102), "Location: the same as BIN-Clock.exe!", rgb(255,191,0)
   Sleep : ImageDestroy dclock   : End 1   ' free used ressources,return errorlevel=1
EndIf
Color rgba(r,g,b,a), rgba(255,255,255,a)' black on white BG

' initialize the arrays PX(), PY() (without typing too much), defines _
' the Paint 'Points (x, y)' used later by 'DoPaint' Sub
For i As Long = 0 To 5
   PX(i) = 105 + i*50               ' the 105 is the starting point (80+25) _
Next                           ' + i*50 is the increment by 50
For i As Long = 0 To 2
   PY(i) = 50 + i*50
Next


' ----- local procedures ----- '
Sub GetTime(ByRef hh As Long, ByRef mm As Long, ByRef ss As Long, ByRef TStr As String)
   TStr = Time
   hh = Val(Left(TStr, 2))
   mm = Val(Mid(TStr, 4, 2))
   ss = Val(Right(TStr, 2))
End Sub


Sub ConvToBIN(ByVal Num As Long)
   ' reset array to 0 (all positions) to have a defined start ...
   For i As Long = 0 To 5
      bi(i) = 0                        ' 0 = false, using Long's as Boolean's
   Next
   ' we now only have to set the 'proper' bits: max. is 59 Min/Sec (max. 6 bits), _
   ' set bi() and get/set the 'remainder' ... no Boolean's in Ver. 1.03.0 yet!
   If Num >= 32 Then bi(0) = 1 : Num mod= 32   ' assign top down ...
   If Num >= 16 Then bi(1) = 1 : Num mod= 16   ' 1 = true (C-style), in FB = -1
   If Num >= 8  Then bi(2) = 1 : Num mod= 8
   If Num >= 4  Then bi(3) = 1 : Num mod= 4
   If Num >= 2  Then bi(4) = 1 : Num mod= 2
   If Num  = 1  Then bi(5) = 1
End Sub


Sub DoPaint (ByVal y As Long, ByVal a As UByte)   ' a = alpha channel (color)
   For i As Long = 0 To 5
      If i = 0 AndAlso y = 0 Then
         Draw String (PX(i)-12, PY(y)-10), "NOT", rgba(159,159,159,a)' bright grey
         Draw String (PX(i)-16, PY(y)), "used", rgba(159,159,159,a)
      Else
         If bi(i) = 1 Then
            Paint (PX(i), PY(y)), rgba(255,0,0,a), rgba(0,0,0,a)   ' red (active)
         Else
            Paint (PX(i), PY(y)), rgba(91,91,91,127), rgba(0,0,0,a)   ' dark grey, semi trans.
         EndIf
      EndIf
   Next
End Sub
' ----- end local procedures ----- '

' ===== MAIN ===== '
Dim As String Title = "Binary - Clock, MrSwiss made(TM)"   ' define 'local var's' to main
Dim As String Help  = "0/32  0/16   0/8   0/4    0/2   0/1"   ' show binary 'weight' of digit
#IfDef __FB_WIN32__   ' Compiler decision: Title used instead of "BIN-Clock", the .EXE name ...
WindowTitle "BINARY - ClockV2 - x32"
#EndIf   ' __FB_WIN32__
#IfDef __FB_64BIT__
WindowTitle "BINARY - ClockV2 - x64"
#EndIf   ' __FB_64BIT__
' NOTE: on other operating systems the relevant intrinsic defines needed (this is WIN only)

Do
   If Time <> TStr Then                  ' sleep until second increments
      CLS                        ' clear screen buffer
      GetTime(hh, mm, ss, TStr)            ' once a second: get new values 24h, aka 'system time'
      ScreenLock
      'Paint (0, 0), rgba(255,255,191,127)      ' paint BG bright yellow, to 'see' the loaded graphics
      For j As Long = 25 To 125 Step 50      ' y-axis (3 times)
         For i As Long = 80 To 330 Step 50   ' x-axis (6   times, except in first row(5), see below)
            If i = 80 AndAlso j = 25 Then   ' if it is the left/top pos. (not needed), do nothing
            Else
               Put (i, j), dclock, Pset   ' plaster the image (50x50px), 17 times to screen
            EndIf
         Next
      Next
      For i As Long = 0 To 2               ' the outlines/contours filling routine ...
         Select Case As Const i
            Case 0
               ConvToBIN(hh)         ' get BINARY for hours: hh (reset, then fill bi() array)
               DoPaint(i, a)         ' 'Paint' the graphics accordingly (uses all three arrays)
            Case 1
               ConvToBIN(mm)
               DoPaint(i, a)
            Case 2
               ConvToBIN(ss)
               DoPaint(i, a)
         End Select
      Next
      ' dynamically centered string on the .BMP's (80+150 pixels = center of graphics [50 x 50px x 6])
      Draw String (230-((Len(Title)+1)\2)*8, 13), Title, rgba(0,63,127,a)   ' dark blue
      Draw String (10, 45), "Hour..: ", rgba(r,g,b,a)   ' default color
      Draw String (90, 72), Help, rgba(r,g,b,a)      ' display calculation help (bit-weight)
      Draw String (10, 95), "Minute: ", rgba(r,g,b,a)
      Draw String (90, 122), Help, rgba(r,g,b,a)
      Draw String (10, 145), "Second: ", rgba(r,g,b,a)
      Draw String (230-((Len(TStr)+1)\2)*8, 180), TStr, rgba(0,63,127,a)   ' d-blue: Time-String, dyn. centered
      ScreenUnLock
   EndIf
   Sleep 200, 1
Loop Until InKey() = chr(255)+"k"               ' until the X is clicked (top/right of window)

ImageDestroy dclock                        ' free allocated ressources (image buffer)
End 0                                 ' finished ... errorlevel=0, for batch use
MrSwiss
Posts: 3726
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: BINARY - Clock "for coder's only" ;-)

Postby MrSwiss » Sep 10, 2016 22:50

Hi all,

Binary Clock, revisited (aka: Version 3.0), New/Changed:
  • No more external *.bmp File
  • only a single Sub GetBinTime()
  • NEW Method to set the Booleans
  • uses a Type now to hold Boolean array's
  • different Color for Hour/Min./Sec.
  • etc. see source code/Comments ...
BinClock.bas:

Code: Select all

' BINARY Clock Version 3.0 - (c) MrSwiss - 2016-09-07/11
' -------------------------------------------------------------------
' Copyright (c) 2016-09-11, MrSwiss (ISO Date Format)
' File Name: BinClock.bas (tested: WIN32/64 | FBC 1.05.0)
' intended use: GUI only! compile using: -s gui
' -------------------------------------------------------------------
' LICENSE:    A donation to the FB-Community! Free for use 'as is'!
' EXCEPTION:  Any and all publishing rights remain exclusively mine!
' WARRANTY:   NONE AT ALL, USE AT YOUR OWN RISK! NO EXCEPTIONS!
' PROHIBITED: Removal of any or all of the above notice(s)!
' -------------------------------------------------------------------

Const As ULong black = &hFF000000, white = &hFFFFFFFF ' Color Const's
Const As ULong trns = &h00FF00FF, grey = &hFF8F8F8F, dgrey = &hFF3F3F3F
Const As ULong red = &hFFFF0000, green = &hFF00FF00, blue = &hFF004FFF

Const As UInteger scrw = 351, scrh = 201 ' Screen Const's

Type BTime ' our Data-Struct(ure)
   As UByte   Seconds ' keeps the last 'updated to' Second
   As Boolean   BTh(2 To 6) ' Booleans used as BIN-Array: hr.
   As Boolean   BTm(1 To 6) ' min.
   As Boolean   BTs(1 To 6) ' sec.
End Type
Dim As BTime BinT ' Size: 18 Bytes

Sub GetBinTime( ByRef B_T As BTime )
   Var ts = Time   ' Time-String, current Time
   Static As UByte hh, mm, ss

   ' first: erase all set Booleans to FALSE (hour, min., sec.) in the Type
   For e As UInteger = 2 To 6 : B_T.BTh(e) = FALSE : Next
   For e As UInteger = 1 To 6 : B_T.BTm(e) = FALSE : B_T.BTs(e) = FALSE : Next

   hh = CUByte(Left(ts, 2))   ' Hour: from String
   mm = CUByte(Mid(ts, 4, 2)) ' Minute: dito
   ss = CUByte(Right(ts, 2)) : B_T.Seconds = ss ' store last update (Sec.)

   For p As UInteger = 1 To 3 ' setting the correct Booleans to TRUE
      With B_T               ' (saves a certain amount of typing)
      Select Case As Const p ' whole eval. is 'inlined' here (for speed!) _
         Case 1             ' instead of calling a external procedure
            Var bs = Bin(hh, 8)        ' binary string
            For b As UInteger = 2 To 6 ' hh range = 0 - 23
               .BTh(b) = bs[b+1] - 48 ' actually: bs[b+2-1], adj. index
            Next
         Case 2
            Var bs = Bin(mm, 8)
            For b As UInteger = 1 To 6 ' mm range = 0 - 59
               .BTm(b) = bs[b+1] - 48
            Next
         Case 3
            Var bs = Bin(ss, 8)
            For b As UInteger = 1 To 6 ' ss range = 0 - 59
               .BTs(b) = bs[b+1] - 48
            Next
      End Select
      End With
   Next
End Sub

ScreenRes(scrw, scrh, 32)
Color black, white : Cls

Dim As Any Ptr IMG = ImageCreate(scrw, scrh,,32)

For j As UInteger = 1 To 3
   Var y = j * 50
   For i As UInteger = 1 To 6
      Var x = i * 50
      Circle IMG, (x, y), 23, black,,,, F
      Circle IMG, (x, y), 17, trns,,,, F
   Next
Next
Circle IMG, (50, 50), 23, white,,,, F ' top/left - hour = never used!
Draw String IMG, ( 29, 10), "red=Hrs." + Space(4) + "green=Mins." + Space(4) + "blue=Secs.", black
Draw String IMG, ( 39, 41), "24h", dgrey : Draw String IMG, ( 31, 52), "Clock", dgrey
Draw String IMG, (113,183), "MrSwiss made(TM)", black

Do
   If BinT.Seconds <> CUByte(Right(Time, 2)) Then ' once a Second only
      GetBinTime(BinT)
      
      ScreenLock
      Cls : Put (0, 0), IMG, Trans
      
      For j As UInteger = 1 To 3
         Var y = j * 50
         For i As UInteger = 1 To 6
            Var x = i * 50
            If j = 1 AndAlso i = 1 Then
               ' don't do anything!
            Else
               Select Case As Const j
                  Case 1
                     If BinT.BTh(i) Then Circle (x, y), 17, red,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
                  Case 2
                     If BinT.BTm(i) Then Circle (x, y), 17, green,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
                  Case 3
                     If BinT.BTs(i) Then Circle (x, y), 17, blue,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
               End Select
            EndIf
         Next
      Next
      ScreenUnLock
   EndIf

   Sleep 200, 1 ' precision <= 200mS
Loop Until Len(InKey())

ImageDestroy(IMG)
jdmcbride
Posts: 27
Joined: Aug 06, 2016 16:13

Re: BINARY - Clock "for coder's only" ;-)

Postby jdmcbride » Sep 12, 2016 0:49

These are so awesome. I'm a nerd and i'm grinning ear-to-ear!
MrSwiss
Posts: 3726
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: BINARY - Clock "for coder's only" ;-)

Postby MrSwiss » Sep 15, 2016 16:09

jdmcbride wrote:These are so awesome. I'm a nerd and i'm grinning ear-to-ear!
Glad you like them ...

A lil update to Version 3.0 --> 3.01:
  • X click, now the only method to close (prevents unwanted close by "any key")
  • compiled program now shows the used Type/Version of FBC in Title Bar.
  • added a few more comments in source

See code or FBC Type&Version ...

BinClock.bas (Ver. 3.01):

Code: Select all

' BINARY Clock Version 3.01 - Copyright (c) MrSwiss - 2016-09-07/13
' ---------------------------------------------------------------------------
' Copyright (c) 2016-09-13, MrSwiss (ISO Date Format)
' File Name: BinClock.bas (tested: WIN32/64 | FBC 1.05.0 | FBC x64 1.06.0)
' intended use: GUI only! compile using: -s gui
' ---------------------------------------------------------------------------
' LICENSE:    A donation to the FB-Community! Free for use 'as is'!
' EXCEPTION:  Any and all publishing rights remain exclusively mine!
' WARRANTY:   NONE AT ALL, USE AT YOUR OWN RISK! NO EXCEPTIONS WHATSOEVER!
' PROHIBITED: Removal of any or all of the above notice(s) icnl. this one!
' ---------------------------------------------------------------------------

Const As ULong black = &hFF000000, white = &hFFFFFFFF ' Color Const's
Const As ULong trns = &h00FF00FF, grey = &hFF8F8F8F, dgrey = &hFF3F3F3F
Const As ULong red = &hFFFF0000, green = &hFF00FF00, blue = &hFF004FFF

Const As UInteger scrw = 351, scrh = 201 ' Screen Const's
Const As String   PROG = "BIN-Clock V3.01 " ' leave a 'spacer'
Const As String   FBTV = "x" + Str(SizeOf(Any Ptr) * 8) + _ ' x32/x64
                         " - FBC " + __FB_VERSION__ ' and Version

Type BTime ' our Data-Struct(ure)
   As UByte   Seconds ' keeps the last 'updated to' Second
   As Boolean   BTh(2 To 6) ' Booleans used as BIN-Array: hr.
   As Boolean   BTm(1 To 6) ' min.
   As Boolean   BTs(1 To 6) ' sec.
End Type
Dim As BTime BinT ' Size: 18 Bytes

Sub GetBinTime( ByRef B_T As BTime )
   Var ts = Time   ' Time-String, current Time
   Static As UByte hh, mm, ss

   ' first: erase all set Booleans to FALSE (hour, min., sec.) in the Type
   For e As UInteger = 2 To 6 : B_T.BTh(e) = FALSE : Next
   For e As UInteger = 1 To 6 : B_T.BTm(e) = FALSE : B_T.BTs(e) = FALSE : Next

   hh = CUByte(Left(ts, 2))   ' Hour: from String
   mm = CUByte(Mid(ts, 4, 2)) ' Minute: dito
   ss = CUByte(Right(ts, 2)) : B_T.Seconds = ss ' store last update (Sec.)

   For p As UInteger = 1 To 3 ' setting the correct Booleans to TRUE
      With B_T               ' (saves a certain amount of typing)
      Select Case As Const p ' whole eval. is 'inlined' here (for speed!) _
         Case 1             ' instead of calling a external procedure
            Var bs = Bin(hh, 8)        ' binary string
            For b As UInteger = 2 To 6 ' hh range = 0 - 23
               .BTh(b) = bs[b+1] - 48 ' actually: bs[b+2-1], adj. index
            Next
         Case 2
            Var bs = Bin(mm, 8)
            For b As UInteger = 1 To 6 ' mm range = 0 - 59
               .BTm(b) = bs[b+1] - 48
            Next
         Case 3
            Var bs = Bin(ss, 8)
            For b As UInteger = 1 To 6 ' ss range = 0 - 59
               .BTs(b) = bs[b+1] - 48
            Next
      End Select
      End With
   Next
End Sub

' ===== MAIN =====
' set up screen
ScreenRes(scrw, scrh, 32)
WindowTitle PROG + FBTV ' program info + FBC Type(x32/x64) & Version info
Color black, white : Cls

' set up the Clock-Face (all that's static in IMG)
Dim As Any Ptr IMG = ImageCreate(scrw, scrh, trns, 32)

For j As UInteger = 1 To 3
   Var y = j * 50
   For i As UInteger = 1 To 6
      Var x = i * 50
      Circle IMG, (x, y), 23, black,,,, F
      Circle IMG, (x, y), 17, trns,,,, F
   Next
Next
Circle IMG, (50, 50), 23, trns,,,, F ' top/left - hour = never used! (overwrite: transparent Color)
Draw String IMG, ( 29, 10), "red=Hrs." + Space(4) + "green=Mins." + Space(4) + "blue=Secs.", black
Draw String IMG, ( 39, 41), "24h", dgrey : Draw String IMG, ( 31, 52), "Clock", dgrey
Draw String IMG, (113,183), "MrSwiss made(TM)", black
' end of init IMG

Do
   If BinT.Seconds <> CUByte(Right(Time, 2)) Then ' once a Second only
      GetBinTime(BinT)
      
      ScreenLock
      Cls : Put (0, 0), IMG, Trans
      
      For j As UInteger = 1 To 3
         Var y = j * 50
         For i As UInteger = 1 To 6
            Var x = i * 50
            If j = 1 AndAlso i = 1 Then
               ' don't do anything!
            Else
               Select Case As Const j
                  Case 1
                     If BinT.BTh(i) Then Circle (x, y), 17, red,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
                  Case 2
                     If BinT.BTm(i) Then Circle (x, y), 17, green,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
                  Case 3
                     If BinT.BTs(i) Then Circle (x, y), 17, blue,,,, F _
                        Else Circle (x, y), 17, grey,,,, F
               End Select
            EndIf
         Next
      Next
      ScreenUnLock
   EndIf

   Sleep 200, 1 ' precision <= 200mS
Loop Until InKey() = Chr(255, 107)   ' X click to quit
' release allocated MEM, reset Pointer ...
ImageDestroy(IMG) : IMG = 0

Return to “Projects”

Who is online

Users browsing this forum: No registered users and 10 guests