;; Simple data plotting package
;; 31-Aug-2000 goetter - First cut for 1.0.1

;; Shortcomings in 1.0.1: Cannot create graphing canvas as a child of the main window;
;; FFI can't process a negative numeric argument; some misinteractions between Today 
;; and the plot window on the PocketPC (P/PC emulation)

;; Usage: (SHOW-PLOT l)
;; where l is a list of the following plotting commands:
;; (ORIGIN x y) - offset the origin to the given x, y coordinates.
;;    Default has the origin at the lower left hand corner, i.e. Quadrant I.
;; (ORIGIN CENTER) - offset the origin to the center of the plotting screen.
;; (SCALE k) - scale all coordinates by 'k'.
;; (COLOR k) - draw in specified color.  k can be RED, BLUE, GREEN, or BLACK;
;;    SOLID-RED, SOLID-BLUE, SOLID-GREEN, or SOLID-BLACK (synonyms of preceding);
;;    HOLLOW-RED, HOLLOW-BLUE, HOLLOW-GREEN, or HOLLOW-BLACK.
;;    The HOLLOW colors draw plotted circle and box-shaped points with a transparent interior;
;;    otherwise, all are solid.
;; (COLOR (RGB r g b)) - draw in specified custom color, where r, g, and b are intensity values 
;;    ranging from 0 to 255.
;; (SHAPE PIXEL) - plot points as single pixels.
;; (SHAPE CIRCLE r) - plot points as circles of radius r.  The circles may be hollow or solid.
;; (SHAPE SQUARE r) - plot points as squares of radius r.  The squares may be hollow or solid.
;; (x y) - plot a point at the given x, y coordinates in the current shape and color.
;; (LINE-WEIGHT k) - draw lines, boxes, and circles with a heavier stroke.
;;    Default k is 1.
;; (LINE p0 p1 ...) - draw a line through each specified point.  Each point is an (x, y) pair.
;;    The line drawn is not fitted, but rather connects each point.  Lines are drawn in the
;;    current weight and color.
;; (CIRCLE x y r) - draw a circle at the coordinates (x, y) of radius r.  The circle is hollow,
;;    but of the current color and line weight.
;; (SQUARE x y r) - draw a square at the coordinates (x, y) of radius r.  The circle is hollow,
;;    but of the current color and line weight.
;;

(require-dll "w32.dll")
(require "w32api.scm")
(require "w32message.scm")
(require "w32struct.scm")

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

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


;; *** d-f-s doesn't yet handle embedded structures well
;;
;(w32:declare-foreign-struct SIPINFO 
;  (cbSize fdwFlags 
;    rcVisibleDesktop 
;    rcSipRect
;    dwImDataSize pvImData)
;  #(dword dword #(dword dword dword dword) #(dword dword dword dword) dword lpvoid))

(w32:declare-foreign-struct SIPINFO 
  (cbSize fdwFlags 
    rcVisibleDesktop-left rcVisibleDesktop-top rcVisibleDesktop-right rcVisibleDesktop-bottom 
    #f dwImDataSize #f)
  #(dword dword 
     dword dword dword dword
     #(dword dword dword dword) dword lpvoid))


(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 (show-plot l)

  (let ((h #f)
      (width 0)
      (height 0)
      (sip-change-pending? #f) ;; SIP management flags for PPC
      (in-foreground? #f)
      (interactive-close? #f)  ;; window manager hack
      (parent-enabled? (iswindowenabled *parent-hwnd*)))

    (define (on-sip-change)
      (if (not in-foreground?)
        (set! sip-change-pending? #t)
        (begin (do-position-windows) (set! sip-change-pending? #f))))

    (define (hide-sip)
      (let ((si (make-SIPINFO)))
        (SIPINFO-cbSize-set! si SIPINFO_sizeof)
        (SIPINFO-fdwFlags-set! si 0)
        (SIPINFO-dwImDataSize-set! si 0)
        (if (shsipinfo SPI_GETSIPINFO 0 si 0)
          (begin
            (SIPINFO-fdwFlags-set! si (bit-and (SIPINFO-fdwFlags si) (bit-not SIPF_ON)))
            (shsipinfo SPI_SETSIPINFO 0 si 0)))))
          
    (define (do-position-windows)
      (let ((rect (make-RECT)))
        (if *windows-ce*
          (begin
            (let ((si (make-SIPINFO)))
              (SIPINFO-cbSize-set! si SIPINFO_sizeof)
              (SIPINFO-fdwFlags-set! si 0)
              (SIPINFO-dwImDataSize-set! si 0)
              (if (shsipinfo SPI_GETSIPINFO 0 si 0)
                (begin
                  (RECT-left-set! rect (SIPINFO-rcVisibleDesktop-left si))
                  (RECT-top-set! rect (SIPINFO-rcVisibleDesktop-top si))
                  (RECT-right-set! rect (SIPINFO-rcVisibleDesktop-right si))
                  (RECT-bottom-set! rect (SIPINFO-rcVisibleDesktop-bottom si)) )
                (systemparametersinfo SPI_GETWORKAREA 0 rect 0)))
            (set! width (+ 1 (- (RECT-right rect) (RECT-left rect))))
            (set! height (+ 1 (- (RECT-bottom rect) (RECT-top rect))))
            ;; $BUGBUG - this should adjust the origin, if autocentered
            (movewindow h (RECT-left rect) (RECT-top rect) width height #f)
            (updatewindow h))
          (begin
            (getclientrect h rect)
            (set! width (RECT-right rect))
            (set! height (RECT-bottom rect)) ))))
    
    (define (do-paint-window hdc)
      (let ((plot-colorref #x00000000)
            (scale-xy 1)
            (origin-x 0)
            (origin-y 0)
            (line-weight 1)
            (basic-fix-coord-x (lambda (x) (round x)))
            (basic-fix-coord-y (lambda (y) (round (- height y))))
            (fix-coord-x #f) ;; dynamically set to procs that adjust coordinates
            (fix-coord-y #f)
            (centered-x? #f) ;; remember if origin is centered, to adjust if scale changes
            (centered-y? #f)
            (save-pen (selectobject hdc (getstockobject BLACK_PEN)))
            (save-brush (selectobject hdc (getstockobject HOLLOW_BRUSH))) )
        
        (define (set-line-weight! w)
          (let ((weight 
                  (cond 
                    ((zero? w) 1)
                    ((and (number? w) (positive? w)) w)
                    (else (error "Invalid line weight" w)))))
            (set! line-weight weight)))
        
        (define (set-scale! k)
          (let ((old-scale scale-xy)
                (new-scale 
                  (cond 
                    ((zero? k) 1)
                    ((number? k) k)
                    (else (error "Invalid scale" k)))))
            (if centered-x?
              (set! origin-x (/ (* origin-x old-scale) new-scale)))
            (if centered-y?
              (set! origin-y (/ (* origin-y old-scale) new-scale)))
            (set! scale-xy new-scale))
          (recalc-coord-adjustments!))
        
        (define (set-origin! x y)
          (let ((new-x (cond
                         ((eq? x 'center)
                          (/ (/ width 2) scale-xy))
                         ((number? x) x)
                         (else (error "Invalid x coordinate" x))))
                (new-y (cond
                         ((eq? y 'center)
                          (/ (/ height 2) scale-xy))
                         ((number? y) y)
                         (else (error "Invalid y coordinate" y)))) )
            (set! centered-x? (eq? x 'center))
            (set! centered-y? (eq? y 'center))
            (set! origin-x new-x)
            (set! origin-y new-y))
          (recalc-coord-adjustments!))
        
        (define (recalc-coord-adjustments!)
          (set! fix-coord-x (if (not (eqv? scale-xy 1))
                              (if (not (zero? origin-x))
                                (lambda (x) (basic-fix-coord-x (* scale-xy (+ origin-x x))))
                                (lambda (x) (basic-fix-coord-x (* scale-xy x))))
                              (if (not (zero? origin-x))
                                (lambda (x) (basic-fix-coord-x (+ origin-x x)))
                                basic-fix-coord-x)))
          (set! fix-coord-y (if (not (eqv? scale-xy 1))
                              (if (not (zero? origin-y))
                                (lambda (x) (basic-fix-coord-y (* scale-xy (+ origin-y x))))
                                (lambda (x) (basic-fix-coord-y (* scale-xy x))))
                              (if (not (zero? origin-y))
                                (lambda (x) (basic-fix-coord-y (+ origin-y x)))
                                basic-fix-coord-y))))

;; $BUGBUG - FFI presently lacks ability to convert a negative numeric argument.
;; Hence all plotting functions must ensure that their coordinates are nonnegative.
                                      
        (define (plot-pixel x y)
          (if (and (not (negative? x)) (not (negative? y)))
             (setpixel hdc x y plot-colorref)))
        
        (define (plot-square-gen x y r f)
          (let ((x1 (- x r)) (y1 (- y r)) (x2 (+ x r)) (y2 (+ y r)))
            (if (and 
                  (not (negative? x1)) 
                  (not (negative? y1))
                  (not (negative? x2))
                  (not (negative? y2)))
              (f hdc x1 y1 x2 y2))))
        (define (plot-square x y r)
          (plot-square-gen x y r rectangle))
        (define (plot-circle x y r)
          (plot-square-gen x y r ellipse))
        
        (define (get-new-line-pen)
          (if (and (eqv? line-weight 1) (eqv? plot-colorref 0))
            (getstockobject BLACK_PEN)
            (createpen PS_SOLID line-weight plot-colorref)))
        (define (draw-square-gen x y r f)
          (let ((new-pen (get-new-line-pen))
                (new-brush (getstockobject HOLLOW_BRUSH)))
            (let ((save-pen (selectobject hdc new-pen))
                  (save-brush (selectobject hdc new-brush)) )
              (f x y (* scale-xy r))
              (selectobject hdc save-pen)
              (selectobject hdc save-brush))
            (deleteobject new-pen)))
        (define (draw-circle x y r)
          (draw-square-gen x y r plot-circle))
        (define (draw-square x y r)
          (draw-square-gen x y r plot-square))
        
        (define (draw-line l)
          (let ((new-pen (get-new-line-pen))
                (num-points (length l)))
            (let ((save-pen (selectobject hdc new-pen))
                  (line (make-POINT-array num-points)))
              (do ((l l (cdr l)) (i 0 (+ i 1)))
                ((null? l))
                (let ((a (car l)))
                   (POINT-array-x-set! line i (fix-coord-x (car a)))
                   (POINT-array-y-set! line i (fix-coord-y (cadr a)))))
              (polyline hdc line num-points)
              (selectobject hdc save-pen))
            (deleteobject new-pen)))
        
        (define (calc-rgb y)
          (case y 
           ((red solid-red hollow-red) #x000000FF) 
           ((green solid-green hollow-green) #x0000FF00) 
           ((blue solid-blue hollow-blue) #x00FF0000)
           ((black solid-black hollow-black) #x00000000)
           (else
             (cond
               ((and (integer? y) (positive? y) (<= y #x00FFFFFF)) y)
               ((and 
                  (pair? y)
                  (eqv? 4 (length y))
                  (eq? 'rgb (car y))
                  (let ((a (cadr y))) (and (integer? a) (not (negative? a)) (< a 256)))
                  (let ((a (caddr y))) (and (integer? a) (not (negative? a)) (< a 256)))
                  (let ((a (cadddr y))) (and (integer? a) (not (negative? a)) (< a 256))))
                (+ (cadr y) (* 256 (caddr y)) (* 65536 (cadddr y))))
               (else (error "Unknown color" y))))))
        
        (define (set-color! keyword)
          (let ((colorref (calc-rgb keyword)))
            (let ((new-pen (case keyword 
                             ((black solid-black hollow-black) (getstockobject BLACK_PEN)) 
                             (else (createpen PS_SOLID 1 colorref)))))
              (if (not new-pen) (error "Couldn't create pen of color" colorref))
              (let ((old-pen (selectobject hdc new-pen)))
                (deleteobject old-pen)))
            (let ((new-brush (case keyword
                               ((hollow-black hollow-blue hollow-green hollow-red) 
                                (getstockobject HOLLOW_BRUSH))
                               ((black solid-black) 
                                (getstockobject BLACK_BRUSH))
                               (else (createsolidbrush colorref)))))
              (if (not new-brush) (error "Couldn't create brush of color" colorref))
              (let ((old-brush (selectobject hdc new-brush)))
                (deleteobject old-brush))) 
            (set! plot-colorref colorref)))
        
        (let ((rect (make-RECT)))
          (RECT-left-set! rect 0)
          (RECT-top-set! rect 0)
          (RECT-right-set! rect width)
          (RECT-bottom-set! rect height)
          (fillrect hdc rect (getstockobject WHITE_BRUSH))
          (drawtext hdc "(Tap window to close.)" #xffffffff rect (bit-or DT_TOP DT_LEFT DT_WORDBREAK)))
        (recalc-coord-adjustments!)
        (let loop ((l l) (plot plot-pixel))
          (if (pair? l)
            (let ((a (car l)))
              (if (not (and (pair? a) (pair? (cdr a))))
                (error "Invalid plot command" a)
                (let ((x (car a)) (y (cadr a)))
                  (case x
                   ((color) 
                    (set-color! y)
                    (loop (cdr l) plot))
                   ((scale)
                    (set-scale! y)
                    (loop (cdr l) plot))
                   ((origin)
                    (if (eq? y 'center)
                      (set-origin! y y)
                      (set-origin! y (caddr a)))
                    (loop (cdr l) plot))
                   ((circle)
                    (draw-circle (fix-coord-x y) (fix-coord-y (caddr a)) (cadddr a))
                    (loop (cdr l) plot))
                   ((square)
                    (draw-square (fix-coord-x y) (fix-coord-y (caddr a)) (cadddr a))
                    (loop (cdr l) plot))
                   ((line-weight)
                    (set-line-weight! y)
                    (loop (cdr l) plot))
                   ((line)
                    (draw-line (cdr a))
                    (loop (cdr l) plot))
                   ((shape)
                    (case y 
                      ((pixel) (loop (cdr l) plot-pixel))
                      ((circle) (loop (cdr l) (lambda (x0 y0) (plot-circle x0 y0 (caddr a)))))
                      ((square) (loop (cdr l) (lambda (x0 y0) (plot-square x0 y0 (caddr a)))))
                      (else (error "Unknown shape" y))))
                   (else
                     (plot (fix-coord-x x) (fix-coord-y y))
                     (loop (cdr l) plot)) )))) ))
        (selectobject hdc save-pen)
        (selectobject hdc save-brush)))
    
         
      
    (dynamic-wind

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

        (set! h (w32:create-window "pscheme-plot" "Data Plot" 
                  ;; Create as a top-level window on NT, a popup on CE.
                  ;; Really needs to be a child on CE so that the P/PC task management
                  ;; doesn't lose it, but that needs more work in pscheme.exe and w32.dll.
                 (list (if *windows-ce* (bit-or WS_VISIBLE WS_POPUP) WS_VISIBLE)) 
                  #f *parent-hwnd* 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_LBUTTONDOWN)
            (set! interactive-close? #t)
            (destroywindow hwnd)
            0)
           
           ((WM_ACTIVATE)
            (set! in-foreground? (not (eqv? WA_INACTIVE (LOWORD (foreign->integer wparam)))))
            (if (and *windows-ce* sip-change-pending? in-foreground?)
              (on-sip-change))
            0)

           ((WM_SETTINGCHANGE)
            (if (and *windows-ce* (eqv? (foreign->integer wparam) SPI_SETSIPINFO))
              (on-sip-change))
            0)
           
           (else (DefWindowProc hwnd msg wparam lparam)))) ) ))

      (lambda ()
        (if *windows-ce* (hide-sip))
        (do-position-windows)
        (showwindow h SW_SHOWNORMAL)
        (enablewindow h #t)
        ;; this would cripple NT - we do not want to disable the desktop window!
        (if *windows-ce* (enablewindow *parent-hwnd* #f))
        ;; SetForegroundWindow necessary because it's the child of the desktop on NT
        (if *windows-ce* (setactivewindow h) (setforegroundwindow h))
        (event-loop-on-wnd h) )

      (lambda ()
        (if *windows-ce* (enablewindow *parent-hwnd* parent-enabled?))
        (destroywindow h)
        (empty-msg-queue)
        ;; CE: parent hwnd is running in different thread, and so needs setforegroundwindow.
        ;; NT is a lost cause, since I don't have the real parent
        (if *windows-ce* ((if interactive-close? setforegroundwindow setactivewindow) *parent-hwnd*))
        (unregisterclass "pscheme-plot" *hinstance*) ) )))