#|
Bug:  this teachpack provides procedures that
      do not check for 1st-order usage.
|#
#lang scheme/base

(require "../private/planet.ss"
         (prefix-in mz: (combine-in scheme/base
                                    htdp/world
                                    lang/posn
                                    (cce define)
                                    (cce function)
                                    (cce require-provide)))
         "../lang/dracula.ss"
         (for-syntax scheme/base))

(mz:define-if-unbound mz:image?
  (mz:block
   (mz:local-require (only-in lang/htdp-advanced image?))
   (mz:eta* image? i)))

(provide (all-defined-out))

;; these need to be syntax that check for 1st order use.

(defun empty-scene (w h) (mz:empty-scene w h))
(defun place-image (i x y s) (mz:place-image i x y s))
(defun add-line (i x y z w c) (mz:add-line i x y z w c))
(defun make-color (r g b) (mz:make-color r g b))
(defun color-red (c) (mz:color-red c))
(defun color-green (c) (mz:color-green c))
(defun color-blue (c) (mz:color-blue c))
(defun rectangle (w h m c) (mz:nw:rectangle w h m c))
(defun circle (r m c) (mz:circle r m c))
(defun text (s f c) (mz:text s f c))
(defun image-width (i) (mz:image-width i))
(defun image-height (i) (mz:image-height i))
(defun overlay (i j) (mz:overlay i j))
(defun overlay/xy (i x y j) (mz:overlay/xy i x y j))
(defun color-list->image (l w h x y) (mz:color-list->image l w h x y))
(defun image->color-list (i) (mz:image->color-list i))
(defun triangle (s m c) (mz:triangle s m c))
(defun star (n o i m c) (mz:star n o i m c))
(defun line (x y c) (mz:line x y c))
(defun put-pinhole (i x y) (mz:put-pinhole i x y))
(defun move-pinhole (i x y) (mz:move-pinhole i x y))
(defun pinhole-x (i) (mz:pinhole-x i))
(defun pinhole-y (i) (mz:pinhole-y i))

(defun image-inside? (i j) (mz:if (mz:image-inside? i j) t nil))
(defun bytep (v) (mz:if (mz:byte? v) t nil))
(defun color? (v) (mz:if (mz:color? v) t nil))
(defun image-color? (v) (mz:if (mz:image-color? v) t nil))
(defun image? (v) (mz:if (mz:image? v) t nil))

(defun mode? (v) (or (equal v 'solid) (equal v 'outline)))

(defun make-posn (x y) (list 'make-posn x y))
(defun posn-x (p) (cadr p))
(defun posn-y (p) (caddr p))

(defun weak-posn? (v)
  (and (true-listp v)
       (= (length v) 3)
       (eq (car v) 'make-posn)))

(defun posn? (v)
  (and (weak-posn? v)
       (integerp (posn-x v))
       (integerp (posn-y v))))

(defun find-image (a b)
  (let* ([p (mz:find-image a b)])
    (make-posn (mz:posn-x p) (mz:posn-y p))))

(defun mouse-eventp (v)
  (and (member v '(button-down button-up drag move enter leave))
       t))

(defun key-eventp (v)
  (or (symbolp v) (characterp v)))

(defun font-size? (v)
  (and (integerp v) (<= 1 v) (<= v 255)))

#|
(defun packet (w m) (mz:make-package w m))
(defun packet-p (x) (mz:package? x))
;;(defun packet-world (p) (mz:package-world p))
;;(defun packet-message (p) (mz:package-message p))

(defconst *localhost* mz:LOCALHOST)
|#

(define-syntaxes ( on-tick-event
                   on-key-event
                   on-redraw
                   stop-when
                   on-mouse-event
                   #|
                   on-receive-event
                   register
                   universe
                   |#
                   big-bang )
  (values 
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:on-tick-event (lambda (w) (cb-name w))) 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:on-key-event (lambda (k w) (cb-name k w)))
                 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:on-redraw (lambda (w) (cb-name w))) 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:stop-when
                  (lambda (w)
                    (mz:if (member (cb-name w) '(nil ())) #f #t)))
                 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:on-mouse-event 
                  (lambda (w x y evt) 
                    (cb-name w x y evt)))
                 't))]))
   #|
   (lambda (stx)
     (syntax-case stx ()
       [(_ cb-name)
        (quasisyntax/loc stx
          (begin (mz:on-receive-event
                  (lambda (w s)
                    (cb-name w s)))
                 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ host name)
        (quasisyntax/loc stx
          (begin (mz:register host name)
                 't))]))
   (lambda (stx)
     (syntax-case stx ()
       [(_ initial process)
        (quasisyntax/loc stx
          (begin (mz:universe
                  (lambda (p1 p2)
                    (initial p1 p2))
                  (lambda (state player message)
                    (process state player message)))
                 't))]))
   |#
   (lambda (stx)
     (syntax-case stx ()
       [(_ width height freq w0)
        (quasisyntax/loc stx
          (begin (mz:big-bang width height freq w0) 't))]
       [_ (raise-syntax-error
           #f
           "big-bang is a procedure that expects 4 arguments"
           stx)]))))