\ winstars.f  14jan01cht, a clock of all planets
\ derived from winclock.f by Tom Zimmer and Rober Smith
\ angular resolution changed from 6 degrees to 1 degree

only forth also definitions

create stars
( moon) 2953 , 60 , 0 , 0 , 0 ,
( mercury ) 8797 , 110 , 0 , 0 , 0 ,
( venus ) 22470 , 120 , 0 , 0 , 0 ,
( earth ) 36526 , 130 , 0 , 0 , 0 ,
( mars ) 68698 , 150 , 0 , 0 , 0 ,
( jupiter ) 433271 , 160 , 0 , 0 , 0 ,
( saturn ) 1075950 , 170 , 0 , 0 , 0 ,
( uranus ) 3068500 , 180 , 0 , 0 , 0 ,
( neptune ) 6019000 , 190 , 0 , 0 , 0 ,
( pluto ) 9080000 , 200 , 0 , 0 , 0 ,

0 value star-days
100 value star-increment
0 value star-select

: period ( -- period ) star-select @ ;
: radius ( -- radius ) star-select 4 + @ ;
: years ( -- year-addr ) star-select 8 + ;
: angle ( -- angle-addr ) star-select 12 + ;
: last-angle ( -- last-angle-addr ) star-select 16 + ;

: moon stars to star-select ;
: mercury stars 20 + to star-select ;
: venus stars 40 + to star-select ;
: earth stars 60 + to star-select ;
: mars stars 80 + to star-select ;
: jupiter stars 100 + to star-select ;
: saturn stars 120 + to star-select ;
: uranus stars 140 + to star-select ;
: neptune stars 160 + to star-select ;
: pluto stars 180 + to star-select ;

: .data cr period . radius . years ? angle ? last-angle ? ;

: get-angle
        star-days period /mod years !
        360 period */ angle ! ;

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
  2 value bit-originy
  0 value VGA-X                 \ VGA x coordinate in pixels
  0 value VGA-Y                 \ VGA y coordinate in pixels

-1 value prev-x
-1 value prev-y

: moveto        ( x y -- )
                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
                ELSE    2dup to prev-y
                             to prev-x
                        MoveTo: demo-dc
                THEN    ;

: lineto        ( x y -- )
                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
                ELSE    2dup to prev-y
                             to prev-x
                        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 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

: makesin       ( -- )
        462 0 do i s>f 3.14159e0 f*
                180e0 f/ fsin
                10000e0 f* f>s
                ,
        loop ;

create sintbl
makesin

: sine ( deg -- sin ) sintbl +cells @ ;
: cosine ( deg -- cos ) 90 + sintbl +cells @ ;

320 value    center-x
175 value    center-y
240 value    scale-y

: >screenx      ( n1 -- n2 )
                screen-width 20000 */ ;

: >screeny      ( n1 -- n2 )
                screen-width 20000 */ ;

: xy-scale      ( deg scale -- x1 y1 )
                >r
                dup        sintbl +CELLS @ >screenx dup r@  center-x */
                swap 1 and +        center-x +
                swap 90 +  sintbl +CELLS @ >screeny dup r>   scale-y */
                swap 1 and + negate center-y + ;

: .hand         ( -- )
                center-x center-y moveto
                last-angle @ radius xy-scale 2dup lineto
                last-angle @ ?dup if 1- else 359 then
                radius 2/ xy-scale lineto
                center-x center-y lineto
                last-angle @ 1+ radius 2/ xy-scale lineto
                lineto ;

: .star         get-angle
                angle @ last-angle @ <>
                IF      black line-color .hand
                        angle @ last-angle !
                THEN
                ;

: .moon       ( -- )
                moon .star
                white line-color .hand ;

: .mercury       ( -- )
                mercury .star
                ltblue line-color .hand ;

: .venus       ( -- )
                venus .star
                ltyellow line-color .hand ;

: .earth        ( -- )
                earth .star
                ltgray line-color .hand ;

: .mars       ( -- )
                mars .star
                ltred line-color .hand ;

: .jupiter      ( -- )
                jupiter .star
                ltgreen line-color .hand ;

: .saturn       ( -- )
                saturn .star
                ltcyan line-color .hand ;

: .uranus       ( -- )
                uranus .star
                ltmagenta line-color .hand ;

: .neptune      ( -- )
                neptune .star
                ltred line-color .hand ;

: .pluto        ( -- )
                pluto .star
                ltblue line-color .hand ;

: .stars          ( -- )
        .pluto .neptune .uranus
        .saturn .jupiter .mars
        .earth .venus .mercury .moon ;

: show-border   ( -- )
                360 0
                do      white  line-color
                        i center-x  1 - xy-scale i 6 + center-x  1 - xy-scale line
                        i center-x 12 - xy-scale i 6 + 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
                6 +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 ;

\ ---------------------------------------------------------------
\ Top Level program starts here
\ ---------------------------------------------------------------

: WinStars      { \ 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
                .stars                            \ 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      new-clock
                                screen-width to  c-width
                                screen-height to c-height
                        then
                        .stars
                        Refresh: GCLOCK
                        WINPAUSE
                        star-days star-increment + to star-days
\                        10 ms
                again   ;

\ ' WinStars turnkey WinStars     \ build an application on disk
\ 5 pause-seconds