Menu
▾
▴
[Win32forth-cvs] win32forth/demos WINCLOCK.F,1.2,1.3
|
From: Jos v.d.V. <jo...@us...> - 2008-04-20 14:04:19
|
Update of /cvsroot/win32forth/win32forth/demos In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv18429 Modified Files: WINCLOCK.F Log Message: Jos: A change made by Dirk. Now a timer is used instead of a delay for a number of MS. Index: WINCLOCK.F =================================================================== RCS file: /cvsroot/win32forth/win32forth/demos/WINCLOCK.F,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** WINCLOCK.F 5 Oct 2005 15:31:21 -0000 1.2 --- WINCLOCK.F 20 Apr 2008 14:04:14 -0000 1.3 *************** *** 3,16 **** only forth also definitions 1280 value screen-mwidth 1024 value screen-mheight - 400 to screen-width - 300 to screen-height \ --------------------------------------------------------------- ! \ Define the BIT-WINDOW global drawing functions \ --------------------------------------------------------------- ! Windc demo-dc 2 value bit-originx \ we have a two pixel border around the bitmap --- 3,24 ---- only forth also definitions + needs NoConsole.f + needs Resources.f + + true value turnkey? + 1280 value screen-mwidth 1024 value screen-mheight \ --------------------------------------------------------------- ! \ Define the AnalogClock window class \ --------------------------------------------------------------- ! :Class AnalogClockChildWindow <super child-window ! ! \ --------------------------------------------------------------- ! \ --------------------------------------------------------------- ! ! Windc Clock-dc 2 value bit-originx \ we have a two pixel border around the bitmap *************** *** 23,174 **** : new-point-chk ( x y -- x y true | false ) ! 0max screen-height 4 - min swap 0max screen-width 4 - min swap ! bit-originy + swap bit-originx + swap ! over prev-x = over prev-y = and ! if 2drop false ( don't draw ) ! else 2dup to prev-y ! to prev-x true ( do draw ) ! then ; : moveto ( x y -- ) new-point-chk ! if ! MoveTo: demo-dc ! then ; : lineto ( x y -- ) new-point-chk ! if ! LineTo: demo-dc ! then ; : line ( x1 y1 x2 y2 -- ) 2swap moveto lineto ; ! : line-color ( color_object -- ) ! LineColor: demo-dc ; ! ! \ --------------------------------------------------------------- ! \ Define the BIT-WINDOW window class ! \ --------------------------------------------------------------- ! ! :Class bit-window <super child-window ! ! int vga-bitmap ! ! :M On_Paint: ( -- ) ! SRCCOPY 0 0 GetHandle: demo-dc GetSize: self 0 0 BitBlt: dc ! ;M ! ! :M Clear: ( -- ) ! 0 0 screen-mwidth screen-mheight BLACK FillArea: demo-dc ! ;M ! ! :M WM_CREATE ( hwnd msg wparam lparam -- res ) ! get-dc ! 0 call CreateCompatibleDC PutHandle: demo-dc ! screen-mwidth screen-mheight CreateCompatibleBitmap: dc ! to vga-bitmap ! vga-bitmap SelectObject: demo-dc drop ! OEM_FIXED_FONT SelectStockObject: demo-dc drop ! WHITE_PEN SelectStockObject: demo-dc drop ! BLACK SetBkColor: demo-dc ! WHITE SetTextColor: demo-dc ! 0 0 screen-mwidth screen-mheight BLACK FillArea: demo-dc ! release-dc ! 0 ;M ! ! :M On_Done: ( -- ) ! vga-bitmap call DeleteObject drop ! 0 to vga-bitmap ! On_Done: super ! ;M ! ! ;Class \ --------------------------------------------------------------- - \ Menu and push button support \ --------------------------------------------------------------- - MENUBAR Demo-Menu-bar - - POPUP "&File" - MENUITEM "E&xit \tAlt-F4" bye ; - - ENDBAR - - :Object GCLOCK <super window - - bit-window vga-bit-window - - 0 constant marginSize \ sets the clock white margin size in pixels - - marginSize constant bitorigx - marginSize constant bitorigy - - bitorigx marginSize + 1+ constant bitrightmargin - bitorigx marginSize + 1+ constant bitbottommargin - - :M On_Init: ( -- ) \ initialize the class - On_Init: super \ first init super class - 2 SetId: vga-bit-window \ then the child window - self Start: vga-bit-window \ then startup child window - \ Demo-menu-bar SetMenuBar: self - ;M - - :M On_Done: ( h m w l -- res ) - 0 call PostQuitMessage drop - On_Done: super - 0 ;M - - :M WM_CLOSE ( h m w l -- res ) - WM_CLOSE WM: Super - bye - 0 ;M - - :M Refresh: ( -- ) - Paint: vga-bit-window - ;M - - :M StartSize: ( -- width height ) \ starting window size - 480 480 - - ;M - - :M StartPos: ( -- x y ) \ starting postion on screen - CenterWindow: Self - ;M - - :M MinSize: ( -- width height ) \ minimum window size - 100 100 - ;M - - :M MaxSize: ( -- width height ) \ maximum window size - screen-mwidth screen-mheight - ;M - - :M WindowTitle: ( -- Zstring ) \ window caption - z" WinClock" - ;M - - \ the l parameter has already been removed by WINDOW.F, and put - \ into Height and Width - - :M On_Size: ( h m w -- ) \ handle resize message - Clear: vga-bit-window - bitorigx bitorigy - Width bitrightmargin - dup to screen-width - Height bitbottommargin - dup to screen-height - Move: vga-bit-window - ;M - - ;Object - - : unload-clock ( -- ) - DestroyWindow: GCLOCK ; - - unload-chain chain-add-before unload-clock - - create sintbl 0 , 25 , 49 , 74 , 97 , 120 , 141 , 160 , --- 31,61 ---- : new-point-chk ( x y -- x y true | false ) ! 0max screen-height 4 - min swap 0max screen-width 4 - min swap ! bit-originy + swap bit-originx + swap ! over prev-x = over prev-y = and ! if 2drop false ( don't draw ) ! else 2dup to prev-y ! to prev-x true ( do draw ) ! then ; : moveto ( x y -- ) new-point-chk ! if MoveTo: Clock-dc ! then ; : lineto ( x y -- ) new-point-chk ! if LineTo: Clock-dc ! then ; : line ( x1 y1 x2 y2 -- ) 2swap moveto lineto ; ! : LineColor ( color_object -- ) ! LineColor: Clock-dc ; \ --------------------------------------------------------------- \ --------------------------------------------------------------- create sintbl 0 , 25 , 49 , 74 , 97 , 120 , 141 , 160 , *************** *** 187,190 **** --- 74,83 ---- 240 value scale-y + :M SetCenter-x: ( n -- ) + to center-x ;M + + :M SetCenter-y: ( n -- ) + to center-y ;M + : >screenx ( n1 -- n2 ) screen-width 480 */ ; *************** *** 192,213 **** : >screeny ( n1 -- n2 ) screen-width 480 */ ; - (( - : makesin ( -- ) - cr - 462 0 - do i 0 d>f fsin f# 240.0 f* f>d 8 d.r - 100 ms - 10 ?cr - 6 +loop ; - - : xxy-scale ( 6deg scale -- x1 y1 ) - >r - dup 6 * 0 d>f fsin f# 240.0 f* f>d drop - >screenx dup r@ center-x */ - swap 1 and + center-x + - swap 15 + 6 * 0 d>f fsin f# 240.0 f* f>d drop - >screeny dup r> scale-y */ - swap 1 and + negate center-y + ; - )) : sin ( deg -- x ) 60 mod sintbl +CELLS @ ; --- 85,88 ---- *************** *** 265,290 **** : .second ( -- ) \ draw second display ! black line-color last-second 60 mod .sec this-second TO last-second ! white line-color this-second 60 mod .sec ; : .minute ( -- ) \ draw minute display this-minute last-minute <> ! IF black line-color last-minute 60 mod .min this-minute TO last-minute THEN ! ltgreen line-color this-minute 60 mod .min ; : .hour ( -- ) \ draw hour display this-hour last-hour <> ! IF black line-color last-hour 5 * last-hour-minute 12 / + 60 mod .hr this-hour TO last-hour this-minute TO last-hour-minute THEN ! ltblue line-color this-hour 5 * this-minute 12 / + 60 mod .hr ; --- 140,165 ---- : .second ( -- ) \ draw second display ! black LineColor last-second 60 mod .sec this-second TO last-second ! white LineColor self this-second 60 mod .sec ; : .minute ( -- ) \ draw minute display this-minute last-minute <> ! IF black LineColor last-minute 60 mod .min this-minute TO last-minute THEN ! ltgreen LineColor this-minute 60 mod .min ; : .hour ( -- ) \ draw hour display this-hour last-hour <> ! IF black LineColor last-hour 5 * last-hour-minute 12 / + 60 mod .hr this-hour TO last-hour this-minute TO last-hour-minute THEN ! ltblue LineColor this-hour 5 * this-minute 12 / + 60 mod .hr ; *************** *** 306,310 **** this-hour TO last-hour ; - 1 value delay-ms 16 value cdiam 0 value ccolor --- 181,184 ---- *************** *** 321,325 **** : show-circle ( -- ) 1 +TO ccolor ! ccolor >color line-color 60 0 DO \ draws dots (lines 1 pixel long) --- 195,199 ---- : show-circle ( -- ) 1 +TO ccolor ! ccolor >color LineColor 60 0 DO \ draws dots (lines 1 pixel long) *************** *** 331,364 **** : .hms ( -- ) ! .second \ draw second ! .minute \ draw minute ! .hour \ draw hour ! show-circle ; \ draw the circles : show-border ( -- ) 60 0 ! do white line-color i center-x 1- xy-scale i 1+ center-x 1- xy-scale line i center-x 12 - xy-scale i 1+ center-x 12 - xy-scale line i 5 mod ! if ltcyan line-color \ 1 second markers i center-x 12 - xy-scale i center-x 1- xy-scale line ! else yellow line-color \ 5 second markers i center-x 20 - xy-scale i center-x 1- xy-scale line then loop ; ! : new-clock ( -- ) \ draw a new clock, screen-width 2/ 1- TO center-x screen-height 2/ 1- TO center-y \ calibrate screen center center-x center-x center-y */ TO scale-y \ calibrate aspect ratio ! white line-color \ default color=white show-border ! show-circle ; \ display the circle : show-time ( -- ) \ show the time if it has changed ! ?second \ if second changed ! if .hms \ and then the time ! then ; \ --------------------------------------------------------------- --- 205,356 ---- : .hms ( -- ) ! .second \ draw second ! .minute \ draw minute ! .hour \ draw hour ! show-circle \ draw the circles ! ; : show-border ( -- ) 60 0 ! do white LineColor i center-x 1- xy-scale i 1+ center-x 1- xy-scale line i center-x 12 - xy-scale i 1+ center-x 12 - xy-scale line i 5 mod ! if ltcyan LineColor \ 1 second markers i center-x 12 - xy-scale i center-x 1- xy-scale line ! else yellow LineColor \ 5 second markers i center-x 20 - xy-scale i center-x 1- xy-scale line then loop ; ! :M Clear: ( -- ) ! 0 0 screen-mwidth screen-mheight BLACK FillArea: Clock-dc ! ;M ! ! :m On_Size: ( -- ) \ draw a new clock, ! On_Size: super ! ! 16 to cdiam ! screen-width 2/ 1- TO center-x screen-height 2/ 1- TO center-y \ calibrate screen center center-x center-x center-y */ TO scale-y \ calibrate aspect ratio ! white LineColor \ default color=white ! Clear: self ! show-border ! init-vars ! .hms ! ;M : show-time ( -- ) \ show the time if it has changed ! ?second if .hms then ; ! ! :m Refresh: ( -- ) ! show-circle ! show-time ! Paint: self ! ;M ! ! \ --------------------------------------------------------------- ! \ --------------------------------------------------------------- ! ! int vga-bitmap ! ! :M On_Paint: ( -- ) ! SRCCOPY 0 0 GetHandle: Clock-dc GetSize: self 0 0 BitBlt: dc ! ;M ! ! :M WM_CREATE ( hwnd msg wparam lparam -- res ) ! get-dc ! 0 call CreateCompatibleDC PutHandle: Clock-dc ! screen-mwidth screen-mheight CreateCompatibleBitmap: dc ! to vga-bitmap ! vga-bitmap SelectObject: Clock-dc drop ! OEM_FIXED_FONT SelectStockObject: Clock-dc drop ! WHITE_PEN SelectStockObject: Clock-dc drop ! BLACK SetBkColor: Clock-dc ! WHITE SetTextColor: Clock-dc ! 0 0 screen-mwidth screen-mheight BLACK FillArea: Clock-dc ! release-dc ! 0 ;M ! ! :M On_Done: ( -- ) ! vga-bitmap call DeleteObject drop ! 0 to vga-bitmap ! On_Done: super ! ;M ! ! ;Class ! ! \ --------------------------------------------------------------- ! \ --------------------------------------------------------------- ! :Object WinClock <super window ! ! AnalogClockChildWindow ClockWindow ! ! 10 constant marginSize \ sets the clock white margin size in pixels ! ! marginSize constant bitorigx ! marginSize constant bitorigy ! ! bitorigx marginSize + 1+ constant bitrightmargin ! bitorigx marginSize + 1+ constant bitbottommargin ! ! :M WM_CLOSE ( h m w l -- res ) ! WM_CLOSE WM: Super bye 0 ;M ! ! :M StartSize: ( -- width height ) \ starting window size ! 480 480 ;M ! ! :M StartPos: ( -- x y ) \ starting postion on screen ! CenterWindow: Self ;M ! ! :M MinSize: ( -- width height ) \ minimum window size ! 100 100 ;M ! ! :M MaxSize: ( -- width height ) \ maximum window size ! screen-mwidth screen-mheight ;M ! ! :M WindowTitle: ( -- Zstring ) \ window caption ! z" WinClock" ;M ! ! \ the l parameter has already been removed by WINDOW.F, and put ! \ into Height and Width ! ! :M On_Size: ( h m w -- ) \ handle resize message ! bitorigx bitorigy ! Width bitrightmargin - dup to screen-width ! Height bitbottommargin - dup to screen-height ! Move: ClockWindow ! ;M ! ! \ --------------------------------------------------------------- ! \ --------------------------------------------------------------- ! :M WM_TIMER ( h m w l -- res ) \ handle the WM_TIMER events ! Refresh: ClockWindow ;M \ refresh the window ! ! :M On_Init: ( -- ) \ initialize the class ! On_Init: super \ first init super class ! 2 SetId: ClockWindow \ then the child window ! self Start: ClockWindow \ then startup child window ! ;M ! ! :M On_Done: ( -- ) \ things to do before program termination ! 1 hWnd Call KillTimer drop \ destroy the timer, we are done ! 0 call PostQuitMessage drop ! On_Done: super \ then do things superclass needs ! ;M ! ! :M Start: ( -- ) ! Start: super ! 0 200 1 hWnd Call SetTimer drop \ init timer to a 200 ms rate ! ;m ! ! ;Object ! ! : unload-clock ( -- ) ! DestroyWindow: WinClock ; ! unload-chain chain-add-before unload-clock \ --------------------------------------------------------------- *************** *** 366,400 **** \ --------------------------------------------------------------- ! : WinClock { \ c-width c-height -- } ! Start: GCLOCK ! RANDOM-INIT \ initialize random numbers ! screen-width 2/ 1- TO center-x ! screen-height 2/ 1- TO center-y \ calibrate screen center ! white line-color \ default color=white ! new-clock ! init-vars \ then initialize variable ! .hms \ show initial time ! screen-width to c-width ! screen-height to c-height ! begin c-width c-height ! screen-width screen-height d= 0= ! if 1 to delay-ms ! 16 to cdiam ! new-clock ! screen-width to c-width ! screen-height to c-height ! then ! show-time \ just keep showing the current time ! show-circle ! Refresh: GCLOCK ! key? drop ! delay-ms 1+ 200 min to delay-ms ! delay-ms ms ! again ; ! false #if ! ' WinClock turnkey WinClock \ build an application on disk ! 1 pause-seconds ! #else ! WinClock ! #then --- 358,380 ---- \ --------------------------------------------------------------- ! : Main ( -- ) ! Start: WinClock ! MessageLoop ; ! ! turnkey? [if] ! ! NoConsoleIO \ Setup the Console I/O for an application without the console window. ! NoConsoleInImage \ Tell Imageman that we don't need the w32fconsole.dll. + \ Create the exe-file + &forthdir count &appdir place + ' Main turnkey WinClock.exe + + \ add the Application icon to the EXE file + s" src\res\Win32For.ico" s" WinClock.exe" Prepend<home>\ AddAppIcon + + 1 pause-seconds bye + [else] + s" src\res\Win32For.ico" s" WinClock.exe" Prepend<home>\ AddAppIcon + Main + [then] |
