is-you/game.scm

(import (scheme base)
        (scheme inexact)
        (hoot ffi)
        (hoot debug)
        (dom canvas)
        (dom document)
        (dom element)
        (dom event)
        (dom image)
        (dom media)
        (dom window)
        (console))


(define game-width    640.0)
(define game-height   480.0)

(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))

(define *element-x* (/ game-width 2.0))

(define-record-type <gelement-type>
  (make-gelement-type interact? image)
  gelement-type?
  (interact? gelement-interact?)
  (image gelement-type-iamge))

(define-record-type <gelement>
  (make-gelement type content)
  gelement?
  (type gelement-type)
  (content gelement-content set-gelement-content!))

(define-record-type <parentheses>
  (make-parentheses type pos content)
  parentheses?
  (type parentheses-type)
  (pos parentheses-pos set-parentheses-pos!)
  (content parentheses-content set-parentheses-content!))

(define-record-type <level>
  (make-level grid left-parenthes right-parenthes)
  level?
  (grid level-grid set-level-grid!)
  (left-parenthes level-left-parenthes set-left-parenthes!)
  (right-parenthes level-right-parenthes set-right-parenthes!))


(define wall (make-gelement (make-gelement-type #f "__________") '()))
(define wall2 (make-gelement (make-gelement-type #f "|") '()))
(define apple (make-gelement (make-gelement-type #t "apple") '(4 5)))
(define air (make-gelement (make-gelement-type #t "") '()))

(define left-parenthes (make-parentheses 'left (cons 0 2) '(+ 1 2 3)))
(define right-parenthes (make-parentheses 'right (cons 0 4) '(1 2 3)))

(define ppp (vector (vector air air air air air)
                    (vector wall wall wall wall wall)
                    (vector air air air air air)
                    (vector wall wall wall wall wall)
                    (vector air air air air air)))

(define *level* (make-level ppp left-parenthes right-parenthes))

(define (set-grid! x y val)
  (vector-set! (vector-ref (level-grid *level*) y) x val))

(define (funcall fun args)
  (cond ((equal? fun '+)
         (apply + args))
        ((equal? fun 'string-append)
         (apply string-append args))))

(define (eval-parenthes content)
  (append '()
          (funcall (car content)
                   (cdr content))))

(define (collide-gelement! x y parenthes)
  (dprint "x" x)
  (dprint "y" y)
  (dprint "content" (parentheses-content parenthes))
  (dprint "par pos" (parentheses-pos parenthes))
  (if (and (and (>= x 0) (>= y 0) (and  (< x (vector-length (level-grid *level*))) (< y (vector-length (level-grid *level*))))))
      (let ((e (vector-ref (vector-ref (level-grid *level*) y) x))
            (len (vector-length (level-grid *level*))))
        (if (and  (< x len) (< y len))
            (if (gelement-interact? (gelement-type e))
                (begin
                  (dprint "Move!")
                  (set-grid! x y air)
                  (set-parentheses-pos! parenthes (cons x y))
                  (set-parentheses-content! parenthes (append (parentheses-content parenthes) (gelement-content e)))
                  (dprint "after-content" (parentheses-content parenthes)))
                (dprint "Boop!"))))
      (dprint "Boop!")))

(define (collide-pareneheses! level)
  (let ((left-parenthes (level-left-parenthes level))
        (right-parenthes (level-right-parenthes level)))
    (if (equal? (parentheses-pos left-parenthes) (parentheses-pos right-parenthes))
        (dprint "eval!"
                (eval-parenthes
                 (append (parentheses-content left-parenthes)
                         (parentheses-content right-parenthes)))))))
;; Draw
(define (draw prev-time)
  (clear-rect context 0.0 0.0 game-width game-height)
  (set-fill-color! context "#140c1c")
  (set-text-align! context "center")
  (set-font! context "bold 24px monospace")
  (let ((grid (level-grid *level*))
        (left-parenthes (level-left-parenthes *level*))
        (right-parenthes (level-right-parenthes *level*))
        )
    ; Draw game element
    (do ((i 0 (+ i 1)))
        ((= i (vector-length grid)))
      (do ((j 0 (+ j 1)))
          ((= j (vector-length grid)))

        (let* ((gele (vector-ref (vector-ref grid j) i))
               (avg-width (/ game-width (vector-length grid)))
               (avg-hight (/ game-height (vector-length grid))))
          (fill-text context (gelement-type-iamge (gelement-type gele)) (* 70 (+ i 1)) (* 50 (+ j 1))))))

    ; Draw left-parenthes

    ;; (fill-text context "("
    ;;            100
    ;;            100)
    (fill-text context "("
               (* (+ (car (parentheses-pos left-parenthes)) 1) 100)
               (* (+ (cdr (parentheses-pos left-parenthes)) 1) 50))

    ; Draw right-parenthes
    (fill-text context ")"
               (* (+ (car (parentheses-pos right-parenthes)) 1) 100)
               (* (+ (cdr (parentheses-pos right-parenthes)) 1) 50))
  (request-animation-frame draw-callback)))
(define draw-callback (procedure->external draw))

(set-element-width! canvas (exact game-width))
(set-element-height! canvas (exact game-height))

(request-animation-frame draw-callback)

;; Input
(define (on-key-down event)
  (let ((key (keyboard-event-code event)))
    (cond
     ((string=? key "KeyA")
      (collide-gelement! (- (car (parentheses-pos (level-left-parenthes *level*))) 1) (cdr (parentheses-pos (level-left-parenthes *level*))) (level-left-parenthes *level*)))
     ((string=? key "KeyD")
      (collide-gelement! (+ (car (parentheses-pos (level-left-parenthes *level*))) 1) (cdr (parentheses-pos (level-left-parenthes *level*))) (level-left-parenthes *level*)))
     ((string=? key "KeyW")
      (collide-gelement! (car (parentheses-pos (level-left-parenthes *level*))) (- (cdr (parentheses-pos (level-left-parenthes *level*))) 1) (level-left-parenthes *level*)))
     ((string=? key "KeyS")
      (collide-gelement! (car (parentheses-pos (level-left-parenthes *level*))) (+ (cdr (parentheses-pos (level-left-parenthes *level*))) 1) (level-left-parenthes *level*)))
     ((string=? key "ArrowLeft")
      (collide-gelement! (- (car (parentheses-pos (level-right-parenthes *level*))) 1) (cdr (parentheses-pos (level-right-parenthes *level*))) (level-right-parenthes *level*)))
     ((string=? key "ArrowRight")
      (collide-gelement! (+ (car (parentheses-pos (level-right-parenthes *level*))) 1) (cdr (parentheses-pos (level-right-parenthes *level*))) (level-right-parenthes *level*)))
     ((string=? key "ArrowUp")
      (collide-gelement! (car (parentheses-pos (level-right-parenthes *level*))) (- (cdr (parentheses-pos (level-right-parenthes *level*))) 1) (level-right-parenthes *level*)))
     ((string=? key "ArrowDown")
      (collide-gelement! (car (parentheses-pos (level-right-parenthes *level*))) (+ (cdr (parentheses-pos (level-right-parenthes *level*))) 1) (level-right-parenthes *level*)))
     )
    (collide-pareneheses! *level*)
    )
  )

(add-event-listener! (current-document) "keydown"
                     (procedure->external on-key-down))