201 lines
7.7 KiB
Scheme
201 lines
7.7 KiB
Scheme
(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 goal)
|
|
level?
|
|
(grid level-grid set-level-grid!)
|
|
(left-parenthes level-left-parenthes set-left-parenthes!)
|
|
(right-parenthes level-right-parenthes set-right-parenthes!)
|
|
(goal level-goal set-level-goal!))
|
|
|
|
|
|
(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)))
|
|
(define right-parenthes (make-parentheses 'right (cons 4 2) '()))
|
|
|
|
(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 "Hello World!"))
|
|
|
|
(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 (convert e)
|
|
(cond ((symbol? e)
|
|
(symbol->string e))
|
|
((number? e)
|
|
(number->string e))
|
|
((string? e)
|
|
e)))
|
|
|
|
(define (convert-iter e)
|
|
(string-append " " (convert e) " "))
|
|
|
|
(define (slist->string slst)
|
|
(apply string-append (map convert-iter slst)))
|
|
|
|
(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))
|
|
(goal (level-goal level)))
|
|
(if (equal? (parentheses-pos left-parenthes) (parentheses-pos right-parenthes))
|
|
(let ((val (eval-parenthes (append (parentheses-content left-parenthes)
|
|
(parentheses-content right-parenthes)))))
|
|
(if (equal? val goal)
|
|
(dprint "Goal!")
|
|
(begin
|
|
(set-parentheses-content! left-parenthes '())
|
|
(set-parentheses-content! right-parenthes `(,val))
|
|
)
|
|
)))))
|
|
|
|
;; 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 grid
|
|
(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)) (* 100 (+ i 1)) (* 50 (+ j 1))))))
|
|
|
|
; Draw left-parenthes
|
|
(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))
|
|
|
|
; Draw hub
|
|
(set-text-align! context "left")
|
|
(fill-text context
|
|
(string-append "(" (slist->string (parentheses-content left-parenthes)))
|
|
0 350)
|
|
|
|
(fill-text context
|
|
(string-append (slist->string (parentheses-content right-parenthes)) ")")
|
|
0 400)
|
|
(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))
|