97 lines
3 KiB
Common Lisp
97 lines
3 KiB
Common Lisp
#!/usr/bin/env emacs -script
|
|
;; -*- lexical-binding: t -*-
|
|
;; run: ./forest-fire forest-fire.config
|
|
(require 'cl-lib)
|
|
;; (setq debug-on-error t)
|
|
|
|
(defmacro swap (a b)
|
|
`(setq ,b (prog1 ,a (setq ,a ,b))))
|
|
|
|
(defconst burning ?B)
|
|
(defconst tree ?t)
|
|
|
|
(cl-defstruct world rows cols data)
|
|
|
|
(defun new-world (rows cols)
|
|
;; When allocating the vector add padding so the border will always be empty.
|
|
(make-world :rows rows :cols cols :data (make-vector (* (1+ rows) (1+ cols)) nil)))
|
|
|
|
(defmacro world--rows (w)
|
|
`(1+ (world-rows ,w)))
|
|
|
|
(defmacro world--cols (w)
|
|
`(1+ (world-cols ,w)))
|
|
|
|
(defmacro world-pt (w r c)
|
|
`(+ (* (mod ,r (world--rows ,w)) (world--cols ,w))
|
|
(mod ,c (world--cols ,w))))
|
|
|
|
(defmacro world-ref (w r c)
|
|
`(aref (world-data ,w) (world-pt ,w ,r ,c)))
|
|
|
|
(defun print-world (world)
|
|
(dotimes (r (world-rows world))
|
|
(dotimes (c (world-cols world))
|
|
(let ((cell (world-ref world r c)))
|
|
(princ (format "%c" (if (not (null cell))
|
|
cell
|
|
?.)))))
|
|
(terpri)))
|
|
|
|
(defun random-probability ()
|
|
(/ (float (random 1000000)) 1000000))
|
|
|
|
(defun initialize-world (world p)
|
|
(dotimes (r (world-rows world))
|
|
(dotimes (c (world-cols world))
|
|
(setf (world-ref world r c) (if (<= (random-probability) p) tree nil)))))
|
|
|
|
(defun neighbors-burning (world row col)
|
|
(let ((n 0))
|
|
(dolist (offset '((1 . 1) (1 . 0) (1 . -1) (0 . 1) (0 . -1) (-1 . 1) (-1 . 0) (-1 . -1)))
|
|
(when (eq (world-ref world (+ row (car offset)) (+ col (cdr offset))) burning)
|
|
(setq n (1+ n))))
|
|
(> n 0)))
|
|
|
|
(defun advance (old new p f)
|
|
(dotimes (r (world-rows old))
|
|
(dotimes (c (world-cols old))
|
|
(cond
|
|
((eq (world-ref old r c) burning)
|
|
(setf (world-ref new r c) nil))
|
|
((null (world-ref old r c))
|
|
(setf (world-ref new r c) (if (<= (random-probability) p) tree nil)))
|
|
((eq (world-ref old r c) tree)
|
|
(setf (world-ref new r c) (if (or (neighbors-burning old r c)
|
|
(<= (random-probability) f))
|
|
burning
|
|
tree)))))))
|
|
|
|
(defun read-config (file-name)
|
|
(with-temp-buffer
|
|
(insert-file-contents-literally file-name)
|
|
(read (current-buffer))))
|
|
|
|
(defun get-config (key config)
|
|
(let ((val (assoc key config)))
|
|
(if (null val)
|
|
(error (format "missing value for %s" key))
|
|
(cdr val))))
|
|
|
|
(defun simulate-forest (file-name)
|
|
(let* ((config (read-config file-name))
|
|
(rows (get-config 'rows config))
|
|
(cols (get-config 'cols config))
|
|
(skip (get-config 'skip config))
|
|
(a (new-world rows cols))
|
|
(b (new-world rows cols)))
|
|
(initialize-world a (get-config 'tree config))
|
|
(dotimes (time (get-config 'time config))
|
|
(when (or (and (> skip 0) (= (mod time skip) 0))
|
|
(<= skip 0))
|
|
(princ (format "* time %d\n" time))
|
|
(print-world a))
|
|
(advance a b (get-config 'p config) (get-config 'f config))
|
|
(swap a b))))
|
|
|
|
(simulate-forest (elt command-line-args-left 0))
|