life-vec.scm

life-vec.scm

(use sdl)
(use srfi-43)
(use math.mt-random)

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

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

(define field1
  (make-vector (* field-width field-height) #f))

(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))
;;    (let ((c0     0)              ;; ・
;;          (c1     1)              ;; →
;;          (c2    -1)              ;; ←
;;          (c3 (+    field-width)) ;; ↓
;;          (c4 (+  1 field-width)) ;;↓→
;;          (c5 (+ -1 field-width)) ;;↓←
;;          (c6 (-    field-width)) ;;↑
;;          (c7 (-  1 field-width)) ;;↑→
;;          (c8 (- -1 field-width)) ;;↑←
;;          (len (* field-width field-height)))
;;      (sdl-fill-rect scr #f 0)
;;      (while (< c0 len)
;;        (let ((lifes (+ (vector-ref field (modulo c1 len))
;;                        (vector-ref field (modulo c2 len))
;;                        (vector-ref field (modulo c3 len))
;;                        (vector-ref field (modulo c4 len))
;;                        (vector-ref field (modulo c5 len))
;;                        (vector-ref field (modulo c6 len))
;;                        (vector-ref field (modulo c7 len))
;;                        (vector-ref field (modulo c8 len)))))
;;          (vector-set!
;;           field1 c0
;;           (if (if (zero? (vector-ref field c0))
;;                 (= lifes 3)
;;                 (< 1 lifes 4))
;;             (begin
;;               (sdl-rect-x-set! dstrect
;;                                (* (modulo c0 field-width)
;;                                   bmp-size))
;;               (sdl-rect-y-set! dstrect
;;                                (* (quotient c0 field-width)
;;                                   bmp-size))
;;               (sdl-blit-surface bmp #f scr dstrect)
;;               1)
;;             0)))
;;        (inc! c0) (inc! c1) (inc! c2)
;;        (inc! c3) (inc! c4) (inc! c5)
;;        (inc! c6) (inc! c7) (inc! c8))
;;      (sdl-flip scr)
;;      (set! field (vector-copy field1)))
;;    (if (end)
;;      num
;;      (loop (+ num 1)))))

(define (main-loop scr bmp dstrect)
  (let loop ((num 0))
    (let ((c0     0)              ;; ・
          (c1     1)              ;; →
          (c2    -1)              ;; ←
          (c3 (+    field-width)) ;; ↓
          (c4 (+  1 field-width)) ;;↓→
          (c5 (+ -1 field-width)) ;;↓←
          (c6 (-    field-width)) ;;↑
          (c7 (-  1 field-width)) ;;↑→
          (c8 (- -1 field-width)) ;;↑←
          (len (* field-width field-height))
          (livs '()))
      (vector-fill! field1 0)
      (while (< c0 len)
        (let ((lifes (+ (vector-ref field (modulo c1 len))
                        (vector-ref field (modulo c2 len))
                        (vector-ref field (modulo c3 len))
                        (vector-ref field (modulo c4 len))
                        (vector-ref field (modulo c5 len))
                        (vector-ref field (modulo c6 len))
                        (vector-ref field (modulo c7 len))
                        (vector-ref field (modulo c8 len)))))
          (when (if (zero? (vector-ref field c0)) (= lifes 3) (< 1 lifes 4))
            (push! livs c0)
            (vector-set! field1 c0 1)))
        (inc! c0) (inc! c1) (inc! c2)
        (inc! c3) (inc! c4) (inc! c5)
        (inc! c6) (inc! c7) (inc! c8))
      (sdl-fill-rect scr #f 0)
      (for-each
       (^ (liv)
         (sdl-rect-x-set! dstrect (* (modulo   liv field-width) bmp-size))
         (sdl-rect-y-set! dstrect (* (quotient liv field-width) bmp-size))
         (sdl-blit-surface bmp #f scr dstrect))
       livs)
      (sdl-flip scr)
      (set! field (vector-copy field1)))
    (if (end)
      num
      (loop (+ num 1)))))

(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)
      )))