Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Graphics "Kaleidoscope" for PBwin 6 & 7

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Graphics "Kaleidoscope" for PBwin 6 & 7

    ' The latest addition to the family - a wonderful baby girl -
    ' influenced my mind. Here is the result. You may increase the
    ' speed markedly by omitting the SLEEP statement. The graphics
    ' is indeed very fast.
    '
    ' November 30, 2003: Minor improvements have been made.
    '
    ' Erik Christensen ----- e.chr@email.dk
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    #INCLUDE "win32api.inc"
    '
    CALLBACK FUNCTION DialCallBack
        STATIC hDC&,Rc AS RECT,i&,hPen&,k&,j&,m1&
        STATIC Ps AS PAINTSTRUCT,N&,N4&,N05&
        STATIC Xmax&,Xmin&,Ymax&,Ymin&,Xstep&,Ystep&,Xmid&,Ymid&
        STATIC X() AS LONG, Y() AS LONG
        STATIC Colour() AS LONG
    
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                DATA &HFF0000???,&H00FF00???,&HFFFF00???,&H0000FF???,&HFF0000???,&HFFFF00???
                DATA &HFF00FF???,&H00FFFF???,&HFFFFFF???,&H808080???,&HC0C0C0???,&H00FFFF???,&H0000FF???
                REDIM Colour(13)
                FOR i=1 TO 13 : Colour(i) = VAL(READ$(i)) : NEXT
                GetClientRect CBHNDL,Rc
                Xmid = rc.nRight \ 2 - 1 : Ymid& = rc.nBottom \ 2
                RANDOMIZE TIMER
                FUNCTION = 1
            CASE %WM_PAINT
                N05 = RND(4,11) : N = N05 * 2 : N4 = 4 * N
                REDIM X(N4),Y(N4)
                Xstep = Xmid \ N05 + 1 : Ystep = Ymid \ N05 + 1 ' + 1 ensures that pattern always fills the whole client area.
                Xmin = Xmid - N05 * Xstep : Ymin = Ymid - N05 * Ystep
                Xmax = Xmid + N05 * Xstep : Ymax = Ymid + N05 * Ystep
                hDC = BeginPaint(CBHNDL, Ps)
                hPen = CreatePen(%PS_SOLID,1,Colour(RND(0, 13)))
                SelectObject hDC, hPen
                FOR i=1 TO N
                    X(i) = Xmin : Y(i) = Ymin + (i-1)*Ystep
                    X(N*3+1-i) = Xmax : Y(N*3+1-i) = Ymin + i*Ystep
                    X(i+N) = Xmin + (i-1)*Xstep : Y(i+N) = Ymax
                    X(N4+1-i) = Xmin + i*Xstep : Y(N4+1-i) = Ymin
                NEXT
                FOR i=1 TO N4
                    j=1 : k& = i + 1
                    DO WHILE k& - i& < N4
                        MoveToEx hDC, X(i), Y(i), BYVAL %NULL
                        m1= 1 + (k MOD N4)
                        LineTo hDC, X(m1), Y(m1)
                        INCR j : k = k + j
                    LOOP
                NEXT
                DeleteObject hPen
                SLEEP 400 ' You may change this to change speed of graphics changing
                EndPaint CBHNDL, Ps
            CASE %WM_MOUSEMOVE
                InvalidateRect CBHNDL,BYVAL %NULL,BYVAL %FALSE
                FUNCTION = 1
            CASE %WM_KEYDOWN
                IF CBWPARAM = %VK_SPACE THEN InvalidateRect CBHNDL,BYVAL %NULL,BYVAL %FALSE ' Space-bar pressed
                FUNCTION = 1
        END SELECT
    END FUNCTION
    '
    FUNCTION PBMAIN
        LOCAL hForm&,rc AS RECT,i&
        SystemParametersInfo %SPI_GETWORKAREA,BYVAL 0, BYVAL VARPTR(rc),BYVAL 0
        DIALOG NEW 0, """Kaleidoscope"" - Change Graphics Pattern With Space-Bar Or By Moving Mouse",,,0,0,%DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN,0 TO hForm&
        MoveWindow hForm&,rc.nLeft,rc.nTop,rc.nRight-rc.nLeft,rc.nBottom-rc.nTop,%TRUE
        DIALOG SHOW MODAL hForm&,CALL DialCallBack
    END FUNCTION
    ------------------




    [This message has been edited by Erik Christensen (edited November 30, 2003).]

  • #2
    ' This version shifts pattern automatically rather slowly. You can pause
    ' shifting of patterns by moving the mouse cursor outside the client area.
    ' You can stop the program completely by using the space-bar.
    '
    ' November 30, 2003: Minor improvements have been made.
    '
    ' Erik Christensen ----- e.chr@email.dk
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    #INCLUDE "win32api.inc"
    '
    CALLBACK FUNCTION DialCallBack
        STATIC hDC&,Rc AS RECT,i&,hPen&,k&,j&,m1&
        STATIC Ps AS PAINTSTRUCT,N&,N4&,N05&
        STATIC Xmax&,Xmin&,Ymax&,Ymin&,Xstep&,Ystep&,Xmid&,Ymid&,XCur&
        STATIC X() AS LONG, Y() AS LONG
        STATIC Colour() AS LONG
        STATIC Pnt AS POINTAPI
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                DATA &HFF0000???,&H00FF00???,&HFFFF00???,&H0000FF???,&HFF0000???,&HFFFF00???
                DATA &HFF00FF???,&H00FFFF???,&HFFFFFF???,&H808080???,&HC0C0C0???,&H00FFFF???,&H0000FF???
                REDIM Colour(13)
                FOR i=1 TO 13 : Colour(i) = VAL(READ$(i)) : NEXT
                GetClientRect CBHNDL,Rc
                Xmid = rc.nRight \ 2 - 1 : Ymid& = rc.nBottom \ 2
                XCur = 1
                RANDOMIZE TIMER
                FUNCTION = 1
            CASE %WM_PAINT
                N05 = RND(5,12) : N = N05 * 2 : N4 = 4 * N
                REDIM X(N4),Y(N4)
                Xstep = Xmid \ N05 + 1 : Ystep = Ymid \ N05 + 1 ' + 1 ensures that pattern always fills the whole client area.
                Xmin = Xmid - N05 * Xstep : Ymin = Ymid - N05 * Ystep
                Xmax = Xmid + N05 * Xstep : Ymax = Ymid + N05 * Ystep
                hDC = BeginPaint(CBHNDL, Ps)
                hPen = CreatePen(%PS_SOLID,1,Colour(RND(0, 13)))
                SelectObject hDC, hPen
                FOR i=1 TO N
                    X(i) = Xmin : Y(i) = Ymin + (i-1)*Ystep
                    X(N*3+1-i) = Xmax : Y(N*3+1-i) = Ymin + i*Ystep
                    X(i+N) = Xmin + (i-1)*Xstep : Y(i+N) = Ymax
                    X(N4+1-i) = Xmin + i*Xstep : Y(N4+1-i) = Ymin
                NEXT
                FOR i=1 TO N4
                    j=1 : k& = i + 1
                    DO WHILE k& - i& < N4
                        MoveToEx hDC, X(i), Y(i), BYVAL %NULL
                        m1= 1 + (k MOD N4)
                        LineTo hDC, X(m1), Y(m1)
                        INCR j : k = k + j
                    LOOP
                NEXT
                DeleteObject hPen
                SLEEP 2000 ' You may change this to change speed of graphics changing
                EndPaint CBHNDL, Ps
                GetCursorPos Pnt
                XCur = -1*XCur : Pnt.x = Pnt.x + XCur
                SetCursorPos Pnt.x, Pnt.y ' "Rock" cursor slightly from side to side
                                          ' to elicit a %WM_MOUSEMOVE message and thereby
                                          ' a new pattern.
            CASE %WM_MOUSEMOVE
                InvalidateRect CBHNDL,BYVAL %NULL,BYVAL %FALSE
                FUNCTION = 1
            CASE %WM_KEYDOWN
                IF CBWPARAM = %VK_SPACE THEN DIALOG END CBHNDL ' Close using the space-bar.
                FUNCTION = 1
        END SELECT
    END FUNCTION
    '
    FUNCTION PBMAIN
        LOCAL hForm&,rc AS RECT,i&
        SystemParametersInfo %SPI_GETWORKAREA,BYVAL 0, BYVAL VARPTR(rc),BYVAL 0
        DIALOG NEW 0, """Kaleidoscope"" - Pause By Moving Mouse Cursor into Caption Area - Stop By Using Space-Bar",,,0,0,%DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN,0 TO hForm&
        MoveWindow hForm&,rc.nLeft,rc.nTop,rc.nRight-rc.nLeft,rc.nBottom-rc.nTop,%TRUE
        DIALOG SHOW MODAL hForm&,CALL DialCallBack
    END FUNCTION
    ------------------




    [This message has been edited by Erik Christensen (edited November 30, 2003).]

    Comment


    • #3
      ' This version 3 uses a two color shifting during creation of each pattern.
      ' This results in even more colorful, but sometimes also slightly asymmetric
      ' coloring. You may experiment with other modifications.
      ' Your children will like it.
      '
      ' Erik Christensen ----- e.chr@email.dk
      Code:
      #COMPILE EXE
      #REGISTER NONE
      #DIM ALL
      #INCLUDE "win32api.inc"
      '
      CALLBACK FUNCTION DialCallBack
          STATIC hDC&,Rc AS RECT,i&,k&,j&,m1&
          STATIC Ps AS PAINTSTRUCT,N&,N4&,N05&
          STATIC Xmax&,Xmin&,Ymax&,Ymin&,Xstep&,Ystep&,Xmid&,Ymid&,XCur&
          STATIC X() AS LONG, Y() AS LONG
          STATIC Colour() AS LONG , hPen() AS LONG
          STATIC Pnt AS POINTAPI
          SELECT CASE CBMSG
              CASE %WM_INITDIALOG
                  DATA &HFF0000???,&H00FF00???,&HFFFF00???,&H0000FF???,&HFF0000???,&HFFFF00???
                  DATA &HFF00FF???,&H00FFFF???,&HFFFFFF???,&H808080???,&HC0C0C0???,&H00FFFF???,&H0000FF???
                  REDIM Colour(13) : REDIM hPen(1)
                  FOR i=1 TO 13 : Colour(i) = VAL(READ$(i)) : NEXT
                  GetClientRect CBHNDL,Rc
                  Xmid = rc.nRight \ 2 - 1 : Ymid& = rc.nBottom \ 2
                  XCur = 1
                  RANDOMIZE TIMER
                  FUNCTION = 1
              CASE %WM_PAINT
                  N05 = RND(5,12) : N = N05 * 2 : N4 = 4 * N
                  REDIM X(N4),Y(N4)
                  Xstep = Xmid \ N05 + 1 : Ystep = Ymid \ N05 + 1 ' + 1 ensures that pattern always fills the whole client area.
                  Xmin = Xmid - N05 * Xstep : Ymin = Ymid - N05 * Ystep
                  Xmax = Xmid + N05 * Xstep : Ymax = Ymid + N05 * Ystep
                  hDC = BeginPaint(CBHNDL, Ps)
                  FOR i = 0 TO 1 : hPen(i) = CreatePen(%PS_SOLID,1,Colour(RND(0, 13))) : NEXT
                 
                  FOR i=1 TO N
                      X(i) = Xmin : Y(i) = Ymin + (i-1)*Ystep
                      X(N*3+1-i) = Xmax : Y(N*3+1-i) = Ymin + i*Ystep
                      X(i+N) = Xmin + (i-1)*Xstep : Y(i+N) = Ymax
                      X(N4+1-i) = Xmin + i*Xstep : Y(N4+1-i) = Ymin
                  NEXT
                  FOR i=1 TO N4
                      j=1 : k& = i + 1
                      DO WHILE k& - i& < N4
                          SelectObject hDC, hPen((i+k) MOD 2) ' try also hPen((i+j) MOD 2)
                          MoveToEx hDC, X(i), Y(i), BYVAL %NULL
                          m1= 1 + (k MOD N4)
                          LineTo hDC, X(m1), Y(m1)
                          INCR j : k = k + j
                      LOOP
                  NEXT
                  FOR i= 0 TO 1 : DeleteObject hPen(i) : NEXT
                  SLEEP 2000 ' You may change this to change speed of graphics changing
                  EndPaint CBHNDL, Ps
                  GetCursorPos Pnt
                  XCur = -1*XCur : Pnt.x = Pnt.x + XCur
                  SetCursorPos Pnt.x, Pnt.y ' "Rock" cursor slightly from side to side
                                            ' to elicit a %WM_MOUSEMOVE message and thereby
                                            ' a new pattern.
              CASE %WM_MOUSEMOVE
                  InvalidateRect CBHNDL,BYVAL %NULL,BYVAL %FALSE
                  FUNCTION = 1
              CASE %WM_KEYDOWN
                  IF CBWPARAM = %VK_SPACE THEN DIALOG END CBHNDL ' Close using the space-bar.
                  FUNCTION = 1
          END SELECT
      END FUNCTION
      '
      FUNCTION PBMAIN
          LOCAL hForm&,rc AS RECT,i&
          SystemParametersInfo %SPI_GETWORKAREA,BYVAL 0, BYVAL VARPTR(rc),BYVAL 0
          DIALOG NEW 0, """Kaleidoscope"" - Pause By Moving Mouse Cursor into Caption Area - Stop By Using Space-Bar",,,0,0,%DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN,0 TO hForm&
          MoveWindow hForm&,rc.nLeft,rc.nTop,rc.nRight-rc.nLeft,rc.nBottom-rc.nTop,%TRUE
          DIALOG SHOW MODAL hForm&,CALL DialCallBack
      END FUNCTION
      ------------------


      [This message has been edited by Erik Christensen (edited November 30, 2003).]

      Comment

      Working...
      X