sracket.rkt

#lang racket/gui
(require racket/set)
(require racket/draw/arrow)
(require "ground-scheme.rkt")
(require "grand-syntax.rkt")

(provide slayer-init screen-size drawing-context)
(provide set-display-procedure! draw-image! fill-image! rectangle load-image)

(provide line-between! draw-ellipsis! arrow)

(provide width height image-size make-bitmap clear-image!)
(provide render-text current-font)
(provide keyup keydn mousemove)

(define (nothing . _)
  nothing)

(define current-drawing-context
  (make-parameter #f))

(define display-procedure nothing)

(define (set-display-procedure! proc)
  (set! display-procedure proc))

(define keydown-bindings (make-hasheq))
(define keyup-bindings (make-hasheq))

(define (keydown-handler key . args)
  (out "keydn for "key" not defined"))

(define (keyup-handler key . args)
  (out "keyup for "key" not defined"))

(define keydn
  (case-lambda
    ((key proc)
     (hash-set! keydown-bindings key proc))
    ((default)
     (set! keydown-handler default))))

(define keyup
  (case-lambda
    ((key proc)
     (hash-set! keyup-bindings key proc))
    ((default)
     (set! keyup-handler default))))


(define (key-press key . args)
  (apply (hash-ref keydown-bindings key
		   (lambda _ keydown-handler)) (if (null? args)
					      `(,key)
					      ;; Ugly hack
					      ;; to make
					      ;; the old demos
					      ;; work
					      args)))

(define (key-release key . args)
  (apply (hash-ref keyup-bindings key
		   (lambda _ keyup-handler)) (if (null? args)
					    `(,key)
					    ;; Ugly hack
					    ;; to make
					    ;; the old demos
					    ;; work
					    args)))
(define mouse-move nothing)

(define (mousemove proc)
  (set! mouse-move proc))

(define slayer-canvas%
  (class canvas%
    (inherit refresh)

    (define previous-x 0)
    (define previous-y 0)
    (define pressed-keys (mutable-set))
    
    (define/override (on-char keyboard-event)
      (let ((code (send keyboard-event get-key-code)))
        (if (eq? code 'release)
            (let ((code (send keyboard-event get-key-release-code)))
	      (set-remove! pressed-keys code)
              (key-release code))
	    (unless (set-member? pressed-keys code)
	      (key-press code)))
        (send this refresh)))
    
    (define/override (on-event mouse-event)
      (let ((x (send mouse-event get-x))
            (y (send mouse-event get-y))
            (type (send mouse-event get-event-type))
            (mouse-key-name (lambda (event-type)
                              (case event-type
                                ((left-up left-down) 'mouse-left)
                                ((middle-up middle-down) 'mouse-middle)
                                ((right-up right-down) 'mouse-right)))))
        (case type
          ((left-up middle-up right-up)
           (key-release (mouse-key-name type) x y))
          ((left-down middle-down right-down)
           (key-press (mouse-key-name type) x y))
          ((motion)
           (let ((dx (- x previous-x))
                 (dy (- y previous-y)))
             (mouse-move x y dx dy)
             (set! previous-x x)
             (set! previous-y y))))
        (send this refresh)))
    
    (super-new (paint-callback (lambda (canvas context)
                                 (parameterize ((current-drawing-context context))
                                   (display-procedure)))))))

(define slayer #false)

(define (slayer-init #:title [title ""] #:width [w 640] #:height [h 480])
  (unless slayer
    (let* ((frayer (new frame% [label title] [width w] [height h]))
	   (canvas (new slayer-canvas% [parent frayer])))
      (send frayer show #true)
      (set! slayer frayer))))

(define (screen-size)
  `(,(send slayer get-width) ,(send slayer get-height)))

(define/memoized (drawing-context object)
  (cond ((is-a? object bitmap%)
	 (let ((context (new bitmap-dc% [bitmap object])))
	   (send context set-brush (new brush% [style 'transparent]))
	   context))
	(else
	 (error "Unable to create drawing context for "object))))

(define (rgb color)
  (let ((blue (bitwise-and color #xff))
	(green (bitwise-and (arithmetic-shift color -8) #xff))
	(red (bitwise-and (arithmetic-shift color -16) #xff)))
    `(,red ,green ,blue)))

(define (rectangle width height [color #f])
  (let ((image (make-bitmap width height #;alpha #true)))
    (when color
      (let* ((`(,red ,green ,blue) (rgb color))
	     (color (make-object color% red green blue))
	     (dc (drawing-context image) #;(new bitmap-dc% [bitmap image])))
	(send dc set-background color)
	(send dc clear)))
    image))

(define (arrow x1 y1 x2 y2)
  (let* ((w (abs (- x1 x2)))
	 (h (abs (- y1 y2)))
	 (image (rectangle w h)))
    (draw-arrow (drawing-context image)
		x1 y1 x2 y2 0 0)
    image))

(define (fill-image! image color)
  (let* ((blue (bitwise-and color #xff))
         (green (bitwise-and (arithmetic-shift color -8) #xff))
         (red (bitwise-and (arithmetic-shift color -16) #xff))
         (color (make-object color% red green blue))
         (dc (new bitmap-dc% [bitmap image])))
    (send dc set-background color)
    (send dc clear)
    image))
	 
(define-syntax (send-image image/context message args ...)
  (cond ((is-a? image/context dc<%>)
	 (send image/context message args ...))
	((is-a? image/context bitmap%)
	 (let ((context (drawing-context image/context)))
	   (send context message args ...)))))

(define (draw-image! image [x 0] [y 0] [target (current-drawing-context)])
  (send-image target draw-bitmap image x y))

(define (clear-image! image)
  (send-image image clear))

(define (line-between! x1 y1 x2 y2 [target (current-drawing-context)])
  (send-image target draw-line x1 y1 x2 y2))

(define (draw-ellipsis! x y w h [target (current-drawing-context)])
  (send-image target draw-arc x y w h 0 (* 8 (atan 1))))

(define (load-image path)
  (read-bitmap path))

(define current-font (make-parameter (make-font)))

(define (render-text string
		     [font (current-font)]
		     [color #false]
		     [background-color #false])
  (let ((measure-context (new record-dc%)))
    (send measure-context set-font font)
    (let-values (((w h baseline-to-bottom extra-vertical-space)
		  (send measure-context get-text-extent string)))
      (let* ((`(,w ,h) (map (lambda (v)
			      (if (inexact? v)
				  (inexact->exact
				   (ceiling v))
				  v))
			    `(,w ,h)))
	     (background (rectangle w h #;background-color))
	     (dc (drawing-context background)))
	(cond (background-color
	       (let* ((`(,r ,g ,b) (rgb background-color))
		      (bg-color (make-object color% r g b)))
		 (send dc set-text-mode 'solid)
		 (send dc set-text-background bg-color)))
	      (else
	       (send dc set-text-mode 'transparent)))
	(send dc set-font font)
	(when color
	  (let* ((`(,r ,g ,b)  (rgb color))
		 (color (make-object color% r g b)))
	    (send dc set-text-foreground color)))
	(send dc draw-text string 0 0)
	background))))

(define (image-size image)
  `(,(send image get-width) ,(send image get-height)))

(define (width image)
  (send image get-width))

(define (height image)
  (send image get-height))