#lang racket/base

;; Compatibility: 2htdp/universe's big-bang expressed in terms of ground-vm and os-big-bang.

(require racket/match)
(require racket/class)
(require racket/async-channel)
(require racket/gui/base)
(require 2htdp/image)
(require "os-big-bang.rkt")

(provide (struct-out stop-with)
	 on-tick
	 on-key
	 on-release
	 on-mouse
	 stop-when
	 to-draw
	 on-draw
	 big-bang)

(struct stop-with (w) #:transparent)

;; This should be part of racket
(define (time-evt msecs)
  (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))

(define (replace-world w1 w2)
  (cond
   [(stop-with? w2) (transition (stop-with-w w2)
				(send-message `(new-state ,(stop-with-w w2)))
				(send-message 'stop))]
   [else (transition w2 (send-message `(new-state ,w2)))]))

(define (stop w n)
  (transition w (unsubscribe n)))

(struct ticker-state (counter interval limit) #:transparent)

(define-syntax on-tick
  (syntax-rules ()
    ((_ tick-expr)
     (on-tick tick-expr 1/28))
    ((_ tick-expr rate-expr)
     (on-tick tick-expr rate-expr 0))
    ((_ tick-expr rate-expr limit-expr)
     (list
      (subscribe 'ticker-handler
		 (message-handlers w
		  ['tick (replace-world w (tick-expr w))]
		  ['stop (stop w 'ticker-handler)]))
      (spawn (os-big-bang (ticker-state 0 rate-expr limit-expr)
			  (subscribe 'stop-listener
				     (message-handlers ts
				      ['stop (transition ts
							 (unsubscribe 'stop-listener)
							 (unsubscribe 'ticker))]))
			  (let loop ((next-alarm-time 0))
			    (subscribe 'ticker
				       (ground-message-handler
					(and w (ticker-state counter interval limit))
					[((list 'timer-alarm next-alarm-time)
					  (time-evt next-alarm-time)
					  => now)
					 (if (and (positive? limit) (>= counter limit))
					     (transition w (unsubscribe 'ticker))
					     (transition (ticker-state (+ counter 1) interval limit)
							 (unsubscribe 'ticker)
							 (loop (+ now (* 1000 interval)))
							 (send-message 'tick)))])))))))))

(define-syntax-rule (on-key key-expr)
  (subscribe 'key-handler
	     (message-handlers w
	      [`(key-down ,kev) (replace-world w (key-expr w kev))]
	      ['stop (stop w 'key-handler)])))

(define-syntax-rule (on-release release-expr)
  (subscribe 'release-handler
	     (message-handlers w
	      [`(key-up ,kev) (replace-world w (release-expr w kev))]
	      ['stop (stop w 'release-handler)])))

(define-syntax-rule (on-mouse mouse-expr)
  (subscribe 'mouse-handler
	     (message-handlers w
	      [`(mouse ,x ,y ,mev) (replace-world w (mouse-expr w x y mev))]
	      ['stop (stop w 'mouse-handler)])))

(define-syntax-rule (stop-when last-world?)
  (subscribe 'stop-when-handler
	     (message-handlers w
	      [`(new-state ,_) (if (last-world? w)
				  (replace-world w (stop-with w))
				  w)]
	      ['stop (stop w 'stop-when-handler)])))

(define-syntax-rule (on-draw render-expr) (to-draw render-expr))

(define-syntax-rule (to-draw render-expr)
  (subscribe 'draw-handler
	     (message-handlers w
	      [`(new-state ,_) (transition w (send-message `(render ,(render-expr w))))]
	      ['stop (stop w 'draw-handler)])))

(define (ui-actions c:ui->world c:world->ui)
  (list 
   (spawn (os-big-bang 'none
		       (subscribe 'inbound-relay
				  (ground-message-handler w
				   [('communication-from-ui
				     c:ui->world
				     => message)
				    (transition w (send-message message))]))
		       (subscribe 'stopper
				  (message-handlers w
				   ['stop (transition w
						      (send-meta-message
						       (lambda ()
							 (async-channel-put c:world->ui 'stop)))
						      (unsubscribe 'inbound-relay)
						      (unsubscribe 'stopper))]))))
   (subscribe 'renderer
	      (message-handlers w
	       [`(render ,scene)
		(transition w
		 (send-meta-message (lambda () (async-channel-put c:world->ui `(render ,scene)))))]
	       ['stop (stop w 'renderer)]))))

(define (make-key-event code)
  (cond
   [(char? code) (string code)]
   [(symbol? code) (symbol->string code)]))

;; Pinched almost without change from collects/2htdp/private/world.rkt
(define (mouse-event->parts e)
  (define x (send e get-x))
  (define y (send e get-y))
  (list 'mouse x y 
	(cond [(send e button-down?) "button-down"]
	      [(send e button-up?)   "button-up"]
	      [(send e dragging?)    "drag"]
	      [(send e moving?)      "move"]
	      [(send e entering?)    "enter"]
	      [(send e leaving?)     "leave"]
	      [else			; (send e get-event-type)
	       (let ([m (send e get-event-type)])
		 (error 'on-mouse (format "Unknown event: ~a" m)))])))

(define universe-canvas%
  (class canvas%
    (init-field c:ui->world)
    (super-new)
    (define/override (on-event e)
      (async-channel-put c:ui->world (mouse-event->parts e)))
    (define/override (on-char e)
      (async-channel-put c:ui->world
			 (match (make-key-event (send e get-key-code))
			   ["release" `(key-up ,(make-key-event (send e get-key-release-code)))]
			   [other `(key-down ,other)])))))

(define (big-bang initial-state . initial-action)
  (define c:ui->world (make-async-channel))
  (define c:world->ui (make-async-channel))

  (define frame (new frame%
		     [label "os-big-bang universe"]
		     [width 500]
		     [height 300]))
  (define image (empty-scene 200 200))
  (define canvas (new universe-canvas%
		      [c:ui->world c:ui->world]
		      [parent frame]
		      [paint-callback
		       (lambda (canvas dc)
			 (send image draw dc
			       0 0
			       0 0
			       (send frame get-width) (send frame get-height)
			       0 0
			       #f))]))
  (send frame show #t)

  (thread (lambda ()
	    (let loop ()
	      (define v (async-channel-get c:world->ui))
	      (match v
		[`(render ,scene)
		 (set! image scene)
		 (send frame resize (image-width image) (image-height image))
		 (send canvas refresh-now)]
		[_ 'ignore])
	      (loop))))
  (thread
   (lambda ()
     (ground-vm (apply os-big-bang
		       initial-state
		       (ui-actions c:ui->world c:world->ui)
		       #;(spawn
			(os-big-bang 'none
				     (subscribe 'echoer
						(message-handlers w
						 [any
						  (transition w
						   (send-meta-message (lambda ()
									(write (list any '-> w))
									(newline))))]))))
		       initial-action)))))