life-hash.scm

life-hash.scm

(use srfi-42)
(use math.mt-random)
(use util.match)
(use sdl)

(define bmp-size 3)

;; point
(define (make-point x y)
  (cons x y))

(define (point-x p)
  (car p))

(define (point-y p)
  (cdr p))

;; field
(define (make-field w h lifes)
  (list w h lifes))

(define (field-width field)
  (ref field 0))

(define (field-height field)
  (ref field 1))

(define (field-lifes field)
  (ref field 2))

(define make-random-field
  (let ((m (make <mersenne-twister> :seed (sys-time))))
    (lambda (w h prob)
      (make-field w h (list-ec (: x 0 w)
                               (: y 0 h)
                               (if (<= (mt-random-real m)
                                       prob))
                               (make-point x y))))))

(define (field-adjacent-point field p dx dy)
  (make-point (modulo (+ (point-x p) dx)
                      (field-width field))
              (modulo (+ (point-y p) dy)
                      (field-height field))))

(define (count-up-adjacent-points tbl field p)
  (for-each
   (match-lambda
    ((dx dy)
     (hash-table-update! tbl
                         (field-adjacent-point field
                                               p
                                               dx
                                               dy)
                         (cut + 1 <>)
                         0)))
   (list-ec (: x -1 2)
            (: y -1 2)
            (not (and (= x 0) (= y 0)))
            (list x y))))

(define (survive-lifes tbl field)
  (let ((lifes (field-lifes field)))
    (hash-table-fold
     tbl
     (lambda (p v lst)
       (if (or (and (or (= v 2) (= v 3))
                     (member p lifes))
               (and (= v 3)
                    (not (member p lifes))))
           (cons p lst)
           lst))
     '())))

(define (next-field field)
  (let ((tbl (make-hash-table 'equal?)))
    (for-each (lambda (p)
                (count-up-adjacent-points tbl
                                          field
                                          p))
              (field-lifes field))
    (make-field (field-width field)
                (field-height field)
                (survive-lifes tbl field))))

;; screen
(define *screen-width* 600)
(define *screen-height* 600)

(define (end)
  (define (end-helper e)
    (let ((count (sdl-poll-event e)))
      (cond ((and (> count 0)
                  (or (= SDL_QUIT (sdl-event-type e))
                      (and (= SDL_KEYUP (sdl-event-type e))
                           (= SDLK_ESCAPE (sdl-event-key-keysym-sym e)))))
             #t)
            (else #f))))
  (let ((e (sdl-make-event)))
    (end-helper e)))

(define (main-loop scr state liv-bmp dstrect)
  (define (write-life tbl)
    (sdl-fill-rect scr #f 0)
    (for-each (lambda (p)
                (sdl-rect-x-set! dstrect (* (point-x p) bmp-size))
                (sdl-rect-y-set! dstrect (* (point-y p) bmp-size))
                (sdl-blit-surface liv-bmp #f scr dstrect))
              (field-lifes tbl))
    (sdl-flip scr))

  (let ((num 0))
    (until (end)
      (write-life (set! state (next-field state)))
      (inc! num))
    num))

(define lis (make-random-field 100 100 0.3))

(define (main args)
  (define (init-bmp bmp)
    (sdl-set-color-key
     bmp (or SDL_SRCCOLORKEY SDL_RLEACCES)
     (sdl-map-rgb (sdl-surface-pixel-format bmp) 255 255 255)))

  (sdl-init SDL_INIT_VIDEO)

  (let* ((scr     (sdl-set-video-mode 600 600 16 0))
         (liv-bmp (sdl-display-format (sdl-load-bmp "life-live.bmp")))
         (dstrect (sdl-make-rect 0 0 3 3))
         (start   (sdl-get-ticks)))
    (init-bmp liv-bmp)
    (let* ((frames (main-loop scr lis liv-bmp dstrect))
           (end (sdl-get-ticks))
           (fps (/ (* frames 1000.0) (- end start))))
      (print fps)
      (sdl-quit)
      ;(show-profile)
      )))