;; Following is an almost literal translation of generic.cpp from the CE 2.0 SDK
;; 30-Nov-1999 goetter - DWORD in FFI no longer accepts negative integers
;; 14-Dec-1999 goetter - raw vector sets no longer automatically truncate reals to integers
;; 12-May-2000 goetter - replace some / with QUOTIENT for the abovementioned raw-vec-sets
;; 31-Aug-2000 goetter - relocated GetDesktopWindow to w32api.scm. Known issues on P/PC.
;; 10-May-2005 goetter - update for 1.2; add minimal Pocket PC support
;; 1-Apr-2006 goetter - update for 1.3: brings itself back to the foreground, calls new w32:host-topmost hack

(require "w32.dll")
(require "w32api.scm")
(require "w32message.scm")
(require "w32ppc.scm")

(w32:declare-foreign-struct RECT (left top right bottom) #(dword dword dword dword))
(w32:declare-foreign-struct POINT (x y) #(dword dword))

;; These two can be opaque (empty field list)
(w32:declare-foreign-struct PAINTSTRUCT () #(handle dword #.RECT_sizeof dword dword (byte 32)))
(w32:declare-foreign-struct MSG () #(handle dword dword dword dword #.POINT_sizeof))

;; For converting lparam to a point
;; Remember to foreign->integer the parameter
(define (HIWORD x) (quotient x #x10000))
(define (LOWORD x) (modulo x #x10000))

;; BUGBUG - need a solution for array-of-struct, as used by PolyLine
(define DWORD_sizeof 4)
(define (make-POINT-array c) (make-raw-vector (/ (* POINT_sizeof c) DWORD_sizeof) 'dword))
(define (POINT-array-x a i) (raw-vector-ref a (+ (* 2 i) 0)))
(define (POINT-array-y a i) (raw-vector-ref a (+ (* 2 i) 1)))
(define (POINT-array-x-set! a i v) (raw-vector-set! a (+ (* 2 i) 0) v))
(define (POINT-array-y-set! a i v) (raw-vector-set! a (+ (* 2 i) 1) v))

;(w32:declare-foreign-struct LOGFONT 
; (height width escapement orientation weight
;  italic underline strikeout charset outprecision clipprecision quality pitchandfamily
;  facename)
; #(dword dword dword dword dword
;   byte byte byte byte byte byte byte byte
;   (wchar 32)) )

(define *hinstance* 
  (cond-expand (windows-ce w32:*host-hinst*) ;; on CE, exported by pscheme.exe
	       (windows-nt 0))) ;; on NT, fake it - it's running within a console

(define *parent-hwnd* 
  (cond-expand (windows-ce w32:*host-hwnd*) ;; on CE, exported by pscheme.exe
	       (windows-nt (getdesktopwindow)))) ;; on NT, use desktop - it's running within a console


(define (event-loop-on-wnd h)
 (let ((msg (make-MSG)))
  (define (next-message) 
   ;; in CE 2.0, GetMessage waits forever when called on a dead hwnd instead of returning -1
   ;; hence this fcn first tests with iswindow
   (if (iswindow h)
    (let ((res (getmessage2 msg h 0 0)))
     (if (or (zero? res) (= res #xffffffff)) #f #t))
    #f))
  (do ((f (next-message) (next-message)))
      ((not f))
   (translatemessage msg)
   (dispatchmessage msg)) ))

(define (event-loop-all)
 (let ((msg (make-MSG)))
  (do ((f (GetMessage msg 0 0 0) (GetMessage msg 0 0 0)))
      ((not f))
   (translatemessage msg)
   (dispatchmessage msg)) ))

;; Necessary for any restart of the function in the same thread.
(define (empty-msg-queue)
 (let ((msg (make-MSG)))
  (do ((f (PeekMessage msg 0 0 0 PM_REMOVE) (PeekMessage msg 0 0 0 PM_REMOVE)))
      ((not f))
   (translatemessage msg)
   (dispatchmessage msg)) ))


(define MAX_SQUARES 20)

(let ((h #f)
      (CLIENT_WIDTH 0)
      (CLIENT_HEIGHT 0)
      (change-color? #f)
      (brush-colors `#(,BLACK_BRUSH ,DKGRAY_BRUSH ,LTGRAY_BRUSH ,WHITE_BRUSH))
      (palette-iterator 3)
      (brush-color WHITE_BRUSH)
      (number-of-squares 0)
      (lower-right (make-POINT-array MAX_SQUARES))
      (sai (make-SHACTIVATEINFO)) ; PPC
     )

 (define (do-paint-window hdc)

  (define SQUARE_SIZE (quotient CLIENT_WIDTH 6))

  (if change-color?
   (begin
    (set! palette-iterator (modulo (+ palette-iterator 1) 4))
    (set! brush-color (vector-ref brush-colors palette-iterator))
    (set! change-color? #f)))

  (let ((hbrush (getstockobject brush-color))
        (pen-color (if (< palette-iterator 2) WHITE_PEN BLACK_PEN))
        (x-middle (quotient CLIENT_WIDTH 2))
        (y-middle (quotient CLIENT_HEIGHT 2)) 
        (rect (make-RECT))
        (line (make-POINT-array 5)) )

   (selectobject hdc (getstockobject pen-color))

   (RECT-left-set! rect 0)
   (RECT-top-set! rect 0)
   (RECT-right-set! rect CLIENT_WIDTH)
   (RECT-bottom-set! rect CLIENT_HEIGHT)
   (fillrect hdc rect hbrush)

   (POINT-array-x-set! line 0 x-middle)
   (POINT-array-y-set! line 0 0)
   (POINT-array-x-set! line 1 x-middle)
   (POINT-array-y-set! line 1 CLIENT_HEIGHT)
   (polyline hdc line 2)

   (POINT-array-x-set! line 0 0)
   (POINT-array-y-set! line 0 y-middle)
   (POINT-array-x-set! line 1 (- CLIENT_WIDTH 1))
   (POINT-array-y-set! line 1 y-middle)
   (polyline hdc line 2)

   (RECT-left-set! rect 1)
   (RECT-top-set! rect 1)
   (RECT-right-set! rect x-middle)
   (RECT-bottom-set! rect y-middle)
   (drawtext hdc "Tap here to close." #xffffffff rect (bit-or DT_TOP DT_LEFT))

   (RECT-left-set! rect 1)
   (RECT-top-set! rect (+ 1 y-middle))
   (RECT-right-set! rect x-middle)
   (RECT-bottom-set! rect CLIENT_HEIGHT)
   (drawtext hdc "Tap here to send to the back of the Z-order." #xffffffff rect (bit-or DT_TOP DT_LEFT DT_WORDBREAK))

   (RECT-left-set! rect (+ 1 x-middle))
   (RECT-top-set! rect (+ 1 y-middle))
   (RECT-right-set! rect CLIENT_WIDTH)
   (RECT-bottom-set! rect CLIENT_HEIGHT)
   (drawtext hdc "Tap here to draw a square." #xffffffff rect (bit-or DT_TOP DT_LEFT DT_WORDBREAK))

   (RECT-left-set! rect (+ 1 x-middle))
   (RECT-top-set! rect 1)
   (RECT-right-set! rect CLIENT_WIDTH)
   (RECT-bottom-set! rect y-middle)
   (drawtext hdc "Tap here to change colors." #xffffffff rect (bit-or DT_TOP DT_LEFT DT_WORDBREAK))

   (drawtext hdc 
    (symbolic-case brush-color
     ((WHITE_BRUSH) "White")
     ((LTGRAY_BRUSH) "Light Gray")
     ((DKGRAY_BRUSH) "Dark Gray")
     ((BLACK_BRUSH) "Black")
     (else "Don't know") )
    #xffffffff rect (bit-or DT_CENTER DT_VCENTER))

   (do ((i 0 (+ i 1)))
       ((= i number-of-squares))
    (let ((x (POINT-array-x lower-right i)))
     (POINT-array-x-set! line 0 x)
     (POINT-array-x-set! line 3 x)
     (POINT-array-x-set! line 4 x))
    (let ((y (POINT-array-y lower-right i)))
     (POINT-array-y-set! line 0 y)
     (POINT-array-y-set! line 1 y)
     (POINT-array-y-set! line 4 y))
    (let ((x (- (POINT-array-x lower-right i) SQUARE_SIZE)))
     (POINT-array-x-set! line 1 x)
     (POINT-array-x-set! line 2 x))
    (let ((y (- (POINT-array-y lower-right i) SQUARE_SIZE)))
     (POINT-array-y-set! line 2 y)
     (POINT-array-y-set! line 3 y))
    (polyline hdc line 5) ) )
  ) ;; end of do-paint-window

 (with-fixed-system-stack (lambda ()
 (dynamic-wind

  (lambda ()
    (w32:register-class "generic" *hinstance* 0 (list 0 (getstockobject WHITE_BRUSH)))

    (if *pocket-pc*
	(SHACTIVATEINFO-cbSize-set! sai SHACTIVATEINFO_sizeof))

    (set! h (w32:create-window "generic" "SDK Generic Example" 
             (list WS_VISIBLE) #f 
	     HWND_DESKTOP
	     0 *hinstance* 
     (lambda (hwnd msg wparam lparam)
      (symbolic-case msg
       ((WM_PAINT)
        (let* ((ps (make-PAINTSTRUCT))
               (hdc (beginpaint hwnd ps)))
         (dynamic-wind
          (lambda () #t)
          (lambda () (do-paint-window hdc))
          (lambda () (endpaint hwnd ps))) )
        0)

       ((WM_SIZE) ; PPC
	(let ((rect (make-RECT)))
	  (getclientrect h rect)
	  (set! CLIENT_WIDTH (RECT-right rect))
	  (set! CLIENT_HEIGHT (RECT-bottom rect)))
	0)

       ((WM_ACTIVATE)
	(if *pocket-pc*
	    (begin
	      (shhandlewmactivate hwnd wparam lparam sai 0)
	      0)
	    (DefWindowProc hwnd msg wparam lparam)))

       ((WM_SETTINGCHANGE)
	(if *pocket-pc*
	    (begin
	      (shhandlewmsettingchange hwnd wparam lparam sai)
	      (let ((rect (make-RECT)))
		(getclientrect hwnd rect)
		(invalidaterect hwnd rect #t))
	      0)
	    (DefWindowProc hwnd msg wparam lparam)))

       ((WM_LBUTTONDOWN)
        (let ((pt (make-POINT)))
         (POINT-x-set! pt (LOWORD (foreign->integer lparam)))
         (POINT-y-set! pt (HIWORD (foreign->integer lparam)))
         (if (< (POINT-x pt) (quotient CLIENT_WIDTH 2))
           (if (< (POINT-y pt) (quotient CLIENT_HEIGHT 2))
            (destroywindow hwnd)
	    (begin
	      (setwindowpos hwnd HWND_BOTTOM 0 0 0 0 
			    (bit-or SWP_NOMOVE SWP_NOSIZE SWP_NOACTIVATE))
	      ;; since on PPC it's now lost, bring it back up after a second
	      (sleep 1000)
	      (setwindowpos hwnd HWND_TOP 0 0 0 0 
			    (bit-or SWP_NOMOVE SWP_NOSIZE SWP_NOACTIVATE))))
           (if (< (POINT-y pt) (quotient CLIENT_HEIGHT 2))
            (begin
             (set! change-color? #t)
             (let ((hdc (getdc hwnd)))
              (dynamic-wind
               (lambda () #t)
               (lambda () (do-paint-window hdc))
               (lambda () (releasedc hwnd hdc)))))
            (if (< number-of-squares MAX_SQUARES)
             (begin
              (POINT-array-x-set! lower-right number-of-squares (POINT-x pt))
              (POINT-array-y-set! lower-right number-of-squares (POINT-y pt))
              (set! number-of-squares (+ number-of-squares 1))
              (let ((hdc (getdc hwnd)))
               (dynamic-wind
                (lambda () #t)
                (lambda () (do-paint-window hdc))
                (lambda () (releasedc hwnd hdc)))) )) ) ))
        0)
              
       ((WM_DESTROY)
        (postquitmessage 0)
        0)

       (else (DefWindowProc hwnd msg wparam lparam)))) ) )

    (if *pocket-pc*
	(let ((si (make-SIPINFO)))
	  (SIPINFO-cbSize-set! si SIPINFO_sizeof)
	  (shsipinfo SPI_GETSIPINFO 0 si 0)
	  (let ((cx (- (SIPINFO-rcVisibleDesktop-right si) (SIPINFO-rcVisibleDesktop-left si)))
		(cy (- (SIPINFO-rcVisibleDesktop-bottom si) (SIPINFO-rcVisibleDesktop-top si)))
		(x (SIPINFO-rcVisibleDesktop-left si))
		(y (SIPINFO-rcVisibleDesktop-top si))
		(sip-on (not (zero? (bit-and (SIPINFO-fdwFlags si) SIPF_ON))))
		(sip-docked (not (zero? (bit-and (SIPINFO-fdwFlags si) SIPF_DOCKED)))))
	    (if (or (not sip-on)
		    (and sip-on (not sip-docked)))
		(let ((rect (make-RECT)))
		  (getwindowrect (shfindmenubar w32:*host-hwnd*) rect)
		  (set! cy (- cy (- (RECT-bottom rect) (RECT-top rect)))) ))
	    (set! CLIENT_WIDTH cx)
	    (set! CLIENT_HEIGHT cy)
	    (setwindowpos h 0 x y cx cy SWP_NOZORDER) ))

	(let ((rect (make-RECT)))
	  (getclientrect h rect)
	  (set! CLIENT_WIDTH (RECT-right rect))
	  (set! CLIENT_HEIGHT (RECT-bottom rect))) )

    (showwindow h SW_SHOWNORMAL)
    (updatewindow h)
    (setforegroundwindow h)
    (w32:host-topmost h)

    )

  (lambda ()
    (event-loop-all) )

  (lambda ()
    (destroywindow h)
    (empty-msg-queue)
    (unregisterclass "generic" *hinstance*) )
 ) ;; end of dynwind
 )) ;; end of with-fixed-system-stack
) ;; end of let