prescheme-demo/game-of-life.scm

;;; game-of-life --- Conway's Game of Life in Pre-Scheme

(define WINDOW_TITLE "Conway's Game of Life")
(define WINDOW_WIDTH 1280)
(define WINDOW_HEIGHT 800)

(define CELL_SIZE 5)
(define FRAME_DELAY 50)
(define GRID_WIDTH (quotient WINDOW_WIDTH CELL_SIZE))
(define GRID_HEIGHT (quotient WINDOW_HEIGHT CELL_SIZE))

(define (main argc argv)
  (ensure-args argc argv)
  (with-sdl
   (sdl-init SDL_INIT_VIDEO)
   (lambda ()
     (with-sdl-window
      (sdl-create-window WINDOW_TITLE
                         SDL_WINDOWPOS_CENTERED
                         SDL_WINDOWPOS_CENTERED
                         WINDOW_WIDTH
                         WINDOW_HEIGHT
                         SDL_WINDOW_SHOWN)
      (lambda (window)
        (with-sdl-renderer
         (sdl-create-renderer window -1 SDL_RENDERER_ACCELERATED)
         (lambda (renderer)
           (with-sdl-event
            (lambda (event)
              (run-application window renderer event))))))))))

(define (ensure-args argc argv)
  ;; type inference hack to get the right signature for main
  (string-length (vector-ref argv (- argc 1)))
  (unspecific))

(define (handle-sdl-error message)
  (define out (current-error-port))
  (write-string message out)
  (write-string ": " out)
  (write-string (sdl-get-error) out)
  (newline out)
  -1)

(define (with-sdl initialized? thunk)
  (if (not initialized?)
      (handle-sdl-error "Could not initialize SDL")
      (let ((result (thunk)))
        (sdl-quit)
        result)))

(define (with-sdl-window window proc)
  (if (null-pointer? window)
      (handle-sdl-error "Could not create window")
      (let ((result (proc window)))
        (sdl-destroy-window window)
        result)))

(define (with-sdl-renderer renderer proc)
  (if (null-pointer? renderer)
      (handle-sdl-error "Could not create renderer")
      (let ((result (proc renderer)))
        (sdl-destroy-renderer renderer)
        result)))

(define (with-sdl-event proc)
  (let* ((event (sdl-create-event))
         (result (proc event)))
    (sdl-destroy-event event)
    result))

(define (run-application window renderer event)
  (let ((grid (initialize-grid)))
    (let loop ((running? #t))
      (when running?
        (cond ((sdl-poll-event event)
               (if (= (sdl-event-type event) SDL_QUIT)
                   (goto loop #f)
                   (goto loop #t)))
              (else
               (update-grid grid)
               (render-grid grid renderer)
               (sdl-delay FRAME_DELAY)
               (goto loop #t)))))
    (destroy-grid grid)
    0))

(define (initialize-grid)
  (define c_srand (external "srand" (=> (integer) unit)))
  (define c_rand (external "rand" (=> () integer)))
  (define c_time (external "time" (=> (integer) integer)))
  (c_srand (c_time 0))
  (grid-unfold (lambda (ix x y)
                 (remainder (c_rand) 2))
               GRID_WIDTH GRID_HEIGHT))

(define (update-grid grid)
  (grid-update! (lambda (ix x y value)
                  (let ((north (grid-ref grid x (- y 1)))
                        (south (grid-ref grid x (+ y 1)))
                        (east  (grid-ref grid (+ x 1) y))
                        (west  (grid-ref grid (- x 1) y))
                        (north-east (grid-ref grid (+ x 1) (- y 1)))
                        (north-west (grid-ref grid (- x 1) (- y 1)))
                        (south-east (grid-ref grid (+ x 1) (+ y 1)))
                        (south-west (grid-ref grid (- x 1) (+ y 1))))
                    (let ((alive? (one? value))
                          (live-neighbours (+ north south east west
                                              north-east north-west
                                              south-east south-west)))
                      (if alive?
                          (cond ((< live-neighbours 2) 0) ;; underpopulation
                                ((> live-neighbours 3) 0) ;; overpopulation
                                (else 1))
                          (cond ((= live-neighbours 3) 1) ;; reproduction
                                (else 0))))))
                grid))

(define (render-grid grid renderer)
  (sdl-set-render-draw-color renderer 0 0 0 255)
  (sdl-render-clear renderer)
  (sdl-set-render-draw-color renderer 255 255 255 255)
  (grid-for-each (lambda (ix x y value)
                   (unless (zero? value)
                     (sdl-render-fill-rect renderer
                                           (* x CELL_SIZE)
                                           (* y CELL_SIZE)
                                           CELL_SIZE
                                           CELL_SIZE)
                     (unspecific)))
                 grid)
  (sdl-render-present renderer)
  (unspecific))