# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1470331610 0
# Node ID cc0aa0d6cc3409350c50d03a48db32e3fb527cc8
# Parent  32d624196ac1395e18cca27fc567f11a832cdb58
World gen

diff -r 32d624196ac1 -r cc0aa0d6cc34 .lispwords
--- a/.lispwords	Thu Aug 04 12:57:14 2016 +0000
+++ b/.lispwords	Thu Aug 04 17:26:50 2016 +0000
@@ -1,3 +1,4 @@
 (1 spit)
 (1 recursively)
 (2 state-machine)
+(1 with-color)
diff -r 32d624196ac1 -r cc0aa0d6cc34 src/main.lisp
--- a/src/main.lisp	Thu Aug 04 12:57:14 2016 +0000
+++ b/src/main.lisp	Thu Aug 04 17:26:50 2016 +0000
@@ -1,16 +1,54 @@
 (in-package #:silt)
 
+;;;; Data
 (defparameter *running* nil)
 (defparameter *running* t)
+(defparameter *debug* nil)
 
-(defparameter *width* 1)
-(defparameter *height* 1)
+(defparameter *screen-width* 1)
+(defparameter *screen-height* 1)
+(defparameter *screen-center-x* 1)
+(defparameter *screen-center-y* 1)
+
+(defparameter *world-exponent* 10)
+(defparameter *world-size* (expt 2 *world-exponent*))
+
+(defparameter *view-x* 0)
+(defparameter *view-y* 0)
+
+(defvar *heightmap* nil)
 
 
+;;;; Colors
+(define-constant +color-white+ 0)
+(define-constant +color-blue+ 1)
+(define-constant +color-yellow+ 2)
+(define-constant +color-cyan+ 3)
+(define-constant +color-snow+ 4)
+(define-constant +color-green+ 5)
+
+(charms/ll:init-pair +color-white+ charms/ll:COLOR_WHITE charms/ll:COLOR_BLACK)
+(charms/ll:init-pair +color-blue+ charms/ll:COLOR_BLUE charms/ll:COLOR_BLACK)
+(charms/ll:init-pair +color-yellow+ charms/ll:COLOR_YELLOW charms/ll:COLOR_BLACK)
+(charms/ll:init-pair +color-cyan+ charms/ll:COLOR_CYAN charms/ll:COLOR_BLACK)
+(charms/ll:init-pair +color-snow+ charms/ll:COLOR_BLACK charms/ll:COLOR_WHITE)
+(charms/ll:init-pair +color-green+ charms/ll:COLOR_GREEN charms/ll:COLOR_BLACK)
+
+(defmacro with-color (color &body body)
+  (once-only (color)
+    `(prog2
+      (charms/ll:attron (charms/ll:color-pair ,color))
+      (progn ,@body)
+      (charms/ll:attroff (charms/ll:color-pair ,color)))))
+
+
+;;;; Utils
 (defun manage-screen ()
   (multiple-value-bind (w h)
       (charms:window-dimensions charms:*standard-window*)
-    (setf *width* w *height* h)))
+    (setf *screen-width* w *screen-height* h
+          *screen-center-x* (floor w 2)
+          *screen-center-y* (floor h 2))))
 
 
 (defmacro render (&body body)
@@ -22,10 +60,10 @@
     (charms:refresh-window charms:*standard-window*)))
 
 (defun clamp-w (x)
-  (clamp 0 (1- *width*) x))
+  (clamp 0 (1- *screen-width*) x))
 
 (defun clamp-h (y)
-  (clamp 0 (1- *height*) y))
+  (clamp 0 (1- *screen-height*) y))
 
 
 (defun write-string-at (string x y)
@@ -55,14 +93,134 @@
             (write-string-at string tx ty)))))
 
 
+;;;; World Generation
+(defun jitter (value spread)
+  (+ value (- (random (* 2.0 spread))
+              spread)))
+
+(defun average (&rest values)
+  (/ (apply #'+ values) (length values)))
+
+
+(defun allocate-heightmap ()
+  (make-array (list *world-size* *world-size*)
+    :element-type 'single-float
+    :initial-element 0.0
+    :adjustable nil))
+
+
+(defun hm-size (heightmap)
+  (first (array-dimensions heightmap)))
+
+(defun hm-ref (heightmap x y)
+  (let ((last (hm-size heightmap)))
+    (aref heightmap
+          (cond
+            ((< -1 x last) x)
+            ((= x last) 0)
+            (t (mod x last)))
+          (cond
+            ((< -1 y last) y)
+            ((= y last) 0)
+            (t (mod y last))))))
+
+
+(defun normalize-heightmap (heightmap)
+  (iterate
+    (for i :from 0 :below (array-total-size heightmap))
+    (for v = (row-major-aref heightmap i))
+    (maximize v :into max)
+    (minimize v :into min)
+    (finally
+      (iterate
+        (with span = (- max min))
+        (for i :from 0 :below (array-total-size heightmap))
+        (for v = (row-major-aref heightmap i))
+        (setf (row-major-aref heightmap i)
+              (/ (- v min) span))))))
+
+
+(defun ds-init (heightmap)
+  (setf (aref heightmap 0 0) 0.5))
+
+
+(defun ds-square (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (jitter (average (hm-ref heightmap (- x radius) (- y radius))
+                         (hm-ref heightmap (- x radius) (+ y radius))
+                         (hm-ref heightmap (+ x radius) (- y radius))
+                         (hm-ref heightmap (+ x radius) (+ y radius)))
+                spread)))
+
+(defun ds-diamond (heightmap x y radius spread)
+  (setf (aref heightmap x y)
+        (jitter (average (hm-ref heightmap (- x radius) y)
+                         (hm-ref heightmap (+ x radius) y)
+                         (hm-ref heightmap x (- y radius))
+                         (hm-ref heightmap x (+ y radius)))
+                spread)))
+
+
+(defun ds-squares (heightmap radius spread)
+  (iterate
+    (for x :from radius :below (hm-size heightmap) :by (* 2 radius))
+    (iterate
+      (for y :from radius :below (hm-size heightmap) :by (* 2 radius))
+      (ds-square heightmap x y radius spread))))
+
+(defun ds-diamonds (heightmap radius spread)
+  (iterate
+    (for i :from 0)
+    (for y :from 0 :below (hm-size heightmap) :by radius)
+    (for shift = (if (evenp i) radius 0))
+    (iterate
+      (for x :from shift :below (hm-size heightmap) :by (* 2 radius))
+      (ds-diamond heightmap x y radius spread))))
+
+
+(defun diamond-square (heightmap)
+  (ds-init heightmap)
+  (let ((spread 0.7)
+        (spread-reduction 0.5))
+    (recursively ((radius (floor (hm-size heightmap) 2))
+                  (spread spread))
+      (when (>= radius 1)
+        (ds-squares heightmap radius spread)
+        (ds-diamonds heightmap radius spread)
+        (recur (/ radius 2)
+               (* spread spread-reduction)))))
+  (normalize-heightmap heightmap)
+  heightmap)
+
+
+;;;;
+(defun move-view (dx dy)
+  (incf *view-x* dx)
+  (incf *view-y* dy))
+
+(defun wrap (coord)
+  (mod coord *world-size*))
+
+(defun terrain-char (x y)
+  (let ((h (aref *heightmap* (wrap x) (wrap y))))
+    (cond ((< h 0.2)  (values #\~ +color-blue+))
+          ((< h 0.3)  (values #\~ +color-cyan+))
+          ((< h 0.32) (values #\_ +color-yellow+))
+          ((< h 0.65) (values #\. +color-green+))
+          ((< h 0.7)  (values #\. +color-white+))
+          ((< h 0.75) (values #\^ +color-white+))
+          ((< h 0.9)  (values #\# +color-white+))
+          (t          (values #\* +color-snow+)))))
+
+
+;;;; Game State Machine
 (defun render-title ()
   (render
-    (let ((cx (floor *width* 2))
-          (cy (floor *height* 2)))
-      (write-centered '("S I L T"
-                        ""
-                        "Press any key to start...")
-                      cx (1- cy)))))
+    (write-centered '("S I L T"
+                      ""
+                      "Press any key to start...")
+                    *screen-center-x*
+                    (1- *screen-center-y*))))
 
 (defun render-intro ()
   (render
@@ -71,6 +229,27 @@
                   "You are the god of a toroidal world.")
                 0 0)))
 
+(defun render-generate ()
+  (render
+    (write-centered "Generating world, please wait..."
+                    *screen-center-x* *screen-center-y*)))
+
+(defun render-map ()
+  (iterate
+    (repeat *screen-width*)
+    (for sx :from 0)
+    (for wx :from *view-x*)
+    (iterate
+      (repeat *screen-height*)
+      (for sy :from 0)
+      (for wy :from *view-y*)
+      (for (values char color) = (terrain-char wx wy))
+      (with-color color
+        (charms:write-char-at-point
+          charms:*standard-window*
+          char
+          sx sy)))))
+
 
 (defun handle-input-title ()
   (charms:disable-non-blocking-mode charms:*standard-window*)
@@ -80,6 +259,34 @@
   (charms:disable-non-blocking-mode charms:*standard-window*)
   (charms:get-char charms:*standard-window*))
 
+(defun handle-input-map ()
+  (iterate
+    (for key = (charms:get-char charms:*standard-window* :ignore-error t))
+    (while key)
+    (case key
+      ((#\Q) (return :quit))
+      ((#\R) (return :regen))
+
+      ((#\h) (move-view  -5   0))
+      ((#\j) (move-view   0   5))
+      ((#\k) (move-view   0  -5))
+      ((#\l) (move-view   5   0))
+      ((#\y) (move-view  -5  -5))
+      ((#\u) (move-view   5  -5))
+      ((#\b) (move-view  -5   5))
+      ((#\n) (move-view   5   5))
+
+      ((#\H) (move-view -30   0))
+      ((#\J) (move-view   0  30))
+      ((#\K) (move-view   0 -30))
+      ((#\L) (move-view  30   0))
+      ((#\Y) (move-view -30 -30))
+      ((#\U) (move-view  30 -30))
+      ((#\B) (move-view -30  30))
+      ((#\N) (move-view  30  30))
+
+      (t (push key *debug*) t))))
+
 
 (defun state-title ()
   (render-title)
@@ -89,18 +296,37 @@
 (defun state-intro ()
   (render-intro)
   (handle-input-intro)
-  (state-quit))
+  (state-generate))
+
+(defun state-generate ()
+  (render-generate)
+  (setf *heightmap* (diamond-square (allocate-heightmap)))
+  (state-map))
+
+(defun state-map ()
+  (charms:enable-non-blocking-mode charms:*standard-window*)
+  (case (handle-input-map)
+    ((:quit)
+     (state-quit))
+    ((:regen)
+     (state-generate))
+    (t
+     (render-map)
+     (sleep 0.1)
+     (state-map))))
 
 (defun state-quit ()
   'goodbye)
 
 
+;;;; Run
 (defun run ()
   (setf *running* t)
   (charms:with-curses ()
     (charms:disable-echoing)
     (charms:enable-raw-input :interpret-control-characters t)
-    ; (charms:enable-non-blocking-mode charms:*standard-window*)
+    (charms:enable-extra-keys charms:*standard-window*)
+    (charms/ll:start-color)
     (state-title)))
 
 ; (run)