ufo

ufo.rkt

#lang racket

;; ---------------------------------------------------------------------------------------------------
;; a functional brain control implementation

(require 2htdp/universe 2htdp/image)

;; decide what is an event on the data stream from the headset
(define meditation? (make-parameter (lambda (prev-med curr-med) (not (eq? 0 curr-med)))))
(define attention? (make-parameter (lambda (prev-att curr-att) #false)))

;; [ *-> Void] -> Boolean
;; launch the (fake) head-set process, a universe that forwards messages from there to world
(define (main)
 (brain-universe)
 (functional-brain))

;; ---------------------------------------------------------------------------------------------------
;; the Jedi world

;; World = Number
;; interpretation: the y coordinate of the UFO

;; B-expression is (list number number)
;; interpretation: (list M A) is a pair of mediatation and attention levels

(define HEIGHT 400)
(define WIDTH  400)
(define HEIGHT0 100)
(define UFO
 (underlay/align "center" "center" (circle 10 "solid" "green") (rectangle 40 4 "solid" "green")))

(define (functional-brain)
 ;; Number -> Image
 (define (create-UFO-scene height)
   (place-image UFO 180 height (empty-scene WIDTH HEIGHT)))

 ;; Word B-expression -> World
 (define (calculate-height-using-meditation height0 message)
   ;(printf "got new meditation value: ~a\n" message)
   (cond
     [(boolean? message) (stop-with height0)]
     [else (define-values (M A) (apply values message))
           (define height1 (+ height0 (if (< M 65) +1 -1)))
           ;; don't let the UFO get out of the interval [0,(- HEIGHT 20)]
           (max 0 (min height1 HEIGHT))]))

 (big-bang HEIGHT0
           (register LOCALHOST)
           (on-receive calculate-height-using-meditation)
           (to-draw create-UFO-scene)))

;; Number Number -> Number
(define (increment reading height)
 (max 0 (min HEIGHT (if (< reading 65) (+ height 1) (- height 1)))))

;; ---------------------------------------------------------------------------------------------------
;; the simulate universe, which forwards messages from the fake head-set reader to the world

(define SQPORT 4567)
(define BRAIN-PORT 13854)

(define (brain-universe)
  (define listener (tcp-listen SQPORT 1 #true LOCALHOST))
  (define (receive-registration in out)
    (sync (handle-evt in (lambda (in) (displayln '(OKAY) out) (flush-output out)))))
  (define previous-attention-box  (box 0))
  (define previous-meditation-box (box 0))
  (define current-attention-box   (box 0))
  (define current-meditation-box  (box 0))
  (define (set-attention! new-attention)
    (set-box! previous-attention-box  (unbox current-attention-box))
    (set-box! current-attention-box  new-attention))
  (define (set-meditation! new-meditation)
    (set-box! previous-meditation-box  (unbox current-meditation-box))
    (set-box! current-meditation-box  new-meditation))
  (define (read-from-headset)
    (define-values (in _out) (tcp-connect LOCALHOST BRAIN-PORT))
    (let loop ()
      (sync
       (handle-evt in
                   (lambda (in)
                     (with-handlers ((exn? (lambda (x) (kill-thread (current-thread)))))
                       (define typ (read-byte in))
                       (cond
                         [(eof-object? typ) 
                          (begin (set-attention! #false) (set-meditation! #false))
                          ]
                         [else
                          (case typ
                            [(4) (begin (set-attention! (read-byte in)) (loop)) ]
                            [(5) (begin (set-meditation! (read-byte in)) (loop)) ]
                            [else (loop)])])))))))
  
  
  (define (write-to-world out)
    ;; S-expression -> Void
    (define (send x) (write x out) (newline out) (flush-output out))
    ;; -- IN --
    ;; (Number Number -> Void) Number Number #:att Number #:med Number -> Void
    ;; if it is an attention or a meditation event, send it to the world
    (define (check loop)
      (let* ([previous-attention  (unbox previous-attention-box)]
             [previous-meditation (unbox previous-attention-box)]
             [current-attention   (unbox current-attention-box)]
             [current-meditation  (unbox current-meditation-box)])
        (when (or ((attention?) previous-attention current-attention) 
                  ((meditation?) previous-meditation current-meditation))
          ;(printf "sending med: ~a att: ~a\n" current-meditation current-attention)
          (send `(,current-meditation ,current-attention))
          (sleep 0.1)
          )
        (loop)))
    (let loop () (check loop)))
;      (sync (handle-evt in (lambda (in)
;        (with-handlers ((exn? (lambda (x) (kill-thread (current-thread)))))
;          (check loop)))))))
  
  (thread (lambda () (read-from-headset)))
  
  (thread 
   (lambda () 
     ;; registering
     (define-values (in out) (tcp-accept listener))
     (receive-registration in out)
     (write-to-world out)))
  )

;; ---------------------------------------------------------------------------------------------------
;; run program run
(main)