life-lis.scm

life-lis.scm

(use sdl)
(use srfi-1)
(use math.mt-random)
(use gauche.sequence)

(define seed (make <mersenne-twister> :seed (sys-time)))
(define bmp-size 3)
(define field-width 200)
(define field-height 200)

(define field
  (map (^_
        (map (^_ (mt-random-integer seed 2))
             (make-list field-width #f)))
       (make-list field-height #f)))

(define (offsets l)
  (list l
        (append (drop l 1)       (take l 1))
        (append (take-right l 1) (drop-right l 1))))

(define (next list-of-lists)
  (apply map
         (^ lis
           (apply map
                  (^ k
                    (let ((n (apply + (cdr k))))
                      (if (if (zero? (car k))
                            (= n 3)
                            (< 1 n 4))
                        1
                        0)))
                  (append-map offsets lis)))
         (offsets list-of-lists)))

(define (end)
  (let* ((e (sdl-make-event))
         (count (sdl-poll-event e)))
    (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)))))))

(define (main-loop scr bmp dstrect)
  (let loop ((num 0)
             (state field))
    (sdl-fill-rect scr #f 0)
    (for-each-with-index
     (^ (y-pos u)
       (for-each-with-index
        (^ (x-pos w)
          (unless (zero? w)
            (sdl-rect-x-set! dstrect (* x-pos bmp-size))
            (sdl-rect-y-set! dstrect (* y-pos bmp-size))
            (sdl-blit-surface bmp #f scr dstrect)))
        u))
     state)
    (sdl-flip scr)
    (if (end)
      num
      (loop (+ num 1) (next state)))))

(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))
         (bmp     (sdl-display-format (sdl-load-bmp "life-live.bmp")))
         (dstrect (sdl-make-rect 0 0 3 3))
         (start   (sdl-get-ticks)))
    (init-bmp bmp)
    (let* ((frames (main-loop scr bmp dstrect))
           (end (sdl-get-ticks))
           (fps (/ (* frames 1000.0) (- end start))))
      (print fps)
      (sdl-quit)
      ;(show-profile)
      )))