The beginning of a gnurobots clone in Guile 2.0

guilerobots.scm

#!/usr/bin/env guile -s
!#

(use-modules (gnome-2)
             (cairo)
             (system base pmatch)
             (srfi srfi-1)
             (srfi srfi-8)
             (imi frp))
(use-modules (gnome gobject)
             (gnome gobject gsignal)
             (gnome gtk)
             (gnome gtk gdk-event)
             (imi gtk-simple)
             (imi frp-gobject))


(define (simple-assoc key value . rest)
  (if (null? rest)
      (list (cons key value))
      (cons (cons key value)
            (apply simple-assoc rest))))



;;;
;;; The Interface
;;;

(define drawarea (gtk-drawing-area-new))

(define win
  (container (gtk-window-new)
    drawarea))

(connect win 'destroy
         (lambda args
           (gtk-main-quit)
           #f))

;(gtk-widget-grab-default win)

(gtk-widget-show-all win)




;;;
;;; The Robot drawing stuff
;;;

(define *pictdir* "xpm/")

(define (load-robot type)
  (gdk-pixbuf-new-from-file
    (in-vicinity *pictdir*
                 (if (not type)
                     "robot.xpm"
                     (format #f "robot_~a.xpm" type)))))

(define img:robot (load-robot #f))
(define img:robot-north (load-robot 'north))
(define img:robot-east  (load-robot 'east))
(define img:robot-south (load-robot 'south))
(define img:robot-west  (load-robot 'west))

(define (get-robot-picture movement)
  (case movement
    ((up)    img:robot-north)
    ((right) img:robot-east)
    ((down)  img:robot-south)
    ((left)  img:robot-west)
    (else    img:robot)))

(define (draw-robot cr movement x y oldx oldy)
  (let ((img (get-robot-picture movement)))
    (cairo-set-source-rgb cr 1 1 1)
    (cairo-rectangle cr oldx oldy 16 16)
    (cairo-fill cr)
    (gdk-cairo-set-source-pixbuf cr img x y)
    (cairo-paint cr)
    (cairo-stroke cr)))


(define (draw-world cr rob:state)
  (receive (width height) (gtk-widget-get-size-request drawarea)
    (cairo-set-source-rgb cr 1 1 1)
    (cairo-rectangle cr 0 0 width height)
    (cairo-fill cr)
    (cairo-paint cr)
    (apply draw-robot cr rob:state)))
  


(define (getcairo)
  (gdk-cairo-create (get drawarea 'window)))





;;;
;;; Event utilities
;;;

(define (behavior-trace b . inits)
  (let ((n (length inits)))
    (behavior-integrate
      (lambda (new-v trace)
        (cons new-v (list-head trace n)))
      inits
      b)))




;;;
;;; Event stuff
;;;

(gtk-widget-add-events win (list 'key-press-mask 'key-release-mask))

(define *motion-keys*
  (simple-assoc gdk:Up 'up
                gdk:Down 'down
                gdk:Left 'left
                gdk:Right 'right))

(define (key-event->direction-symbol ev)
  (assq-ref *motion-keys*
            (gdk-event-key:keyval ev)))

(define (motionkeyfilter ev)
  (assq (gdk-event-key:keyval ev)
        *motion-keys*))

(define refresh-tick (msec-tick 20))
(define keypress (gobject-event win 'key-press-event))
(define keyrelease (gobject-event win 'key-release-event))
(define expose (gobject-event drawarea 'expose-event))

(define motionkeypress (event-filter motionkeyfilter keypress))
(define motionkeyrelease (event-filter motionkeyfilter keyrelease))

(define keyspressed
  (event-fold (lambda (ev pressed-keys)
                (let ((event-key (key-event->direction-symbol ev)))
                  (case (gdk-event:type ev)
                    ((key-press)
                     (if (not (memq event-key pressed-keys))
                         (cons event-key pressed-keys)
                         pressed-keys))
                    ((key-release)
                     (filter (lambda (key)
                               (not (eq? event-key key)))
                             pressed-keys))
                    (else pressed-keys))))
              (list)
              (event-merge motionkeypress motionkeyrelease)))

(define move-tick
  (event-mask (behavior-process pair? keyspressed)
              refresh-tick))

(define move-event
  (event-map second (event-snapshot move-tick keyspressed)))

(define start-position (cons 20 20))
(define robot-position
  (event-fold (lambda (directions pos)
                (fold (lambda (dir pos)
                        (pmatch pos
                          ((,x . ,y)
                           (case dir
                             ((up)    (cons x (1- y)))
                             ((down)  (cons x (1+ y)))
                             ((left)  (cons (1- x) y))
                             ((right) (cons (1+ x) y))
                             (else pos)))))
                      pos
                      directions))
              start-position
              move-event))

(define robot-state
  (behavior-process (lambda (pos keyspressed)
                      (pmatch pos 
                        (((,x . ,y) (,oldx . ,oldy))
                         (cons (and (not (null? keyspressed))
                                    (car keyspressed))
                               (list x y oldx oldy)))))
                    (behavior-trace robot-position start-position)
                    keyspressed))


(behavior-use robot-state
              (lambda (state)
                (apply draw-robot (getcairo) state)))


(define redraw-event (event-map second (event-snapshot expose robot-state)))

(event-use redraw-event
           (lambda (robot:state)
             (draw-world (getcairo) robot:state)))


;;;
;;; Start the program! :-)
;;;

(gtk-main)