From f265d24c0cacb92c7f7db19f364a155d87938184 Mon Sep 17 00:00:00 2001
From: dozens
Date: Tue, 28 May 2024 15:04:00 -0600
Subject: inits

---
 lib/contains.fnl      |   7 ++
 lib/contains.test.fnl |  11 ++
 lib/either.fnl        |  20 ++++
 lib/either.test.fnl   |  40 +++++++
 lib/head.fnl          |   6 ++
 lib/head.test.fnl     |  11 ++
 lib/index.fnl         |  13 +++
 lib/mill.fnl          |  16 +++
 lib/mill.test.fnl     |   1 +
 lib/tableprint.fnl    |   7 ++
 lib/tail.fnl          |   7 ++
 lib/tail.test.fnl     |   1 +
 main.fnl              | 282 ++++++++++++++++++++++++++++++++++++++++++++++++++
 13 files changed, 422 insertions(+)
 create mode 100644 lib/contains.fnl
 create mode 100644 lib/contains.test.fnl
 create mode 100644 lib/either.fnl
 create mode 100644 lib/either.test.fnl
 create mode 100644 lib/head.fnl
 create mode 100644 lib/head.test.fnl
 create mode 100644 lib/index.fnl
 create mode 100644 lib/mill.fnl
 create mode 100644 lib/mill.test.fnl
 create mode 100644 lib/tableprint.fnl
 create mode 100644 lib/tail.fnl
 create mode 100644 lib/tail.test.fnl
 create mode 100644 main.fnl

diff --git a/lib/contains.fnl b/lib/contains.fnl
new file mode 100644
index 0000000..75275af
--- /dev/null
+++ b/lib/contains.fnl
@@ -0,0 +1,7 @@
+(fn contains [t x]
+  (accumulate [found false
+               _ v (ipairs t)
+               &until found] ; escape early
+    (or found (= x v))))
+
+{: contains}
diff --git a/lib/contains.test.fnl b/lib/contains.test.fnl
new file mode 100644
index 0000000..1c7fb06
--- /dev/null
+++ b/lib/contains.test.fnl
@@ -0,0 +1,11 @@
+(let [{: contains } (require :lib.contains)]
+  (let [given "a list and an element it contains"
+        should "returns true"
+        expected true
+        actual (contains [:apple :orange :pear] :apple)]
+    (assert (= actual expected) (.. "Given " given " should " should)))
+  (let [given "a list and an element it does not contain"
+        should "returns false"
+        expected false
+        actual (contains [:apple :orange :pear] :gorilla)]
+    (assert (= actual expected) (.. "Given " given " should " should))))
diff --git a/lib/either.fnl b/lib/either.fnl
new file mode 100644
index 0000000..24aafca
--- /dev/null
+++ b/lib/either.fnl
@@ -0,0 +1,20 @@
+(local Either {})
+(local Left {})
+(local Right {})
+(setmetatable Right Either)
+(setmetatable Left Either)
+
+(fn Either.new [self x]
+  (local obj { :value (or x {}) })
+  (tset self "__index" self)
+  (setmetatable obj self))
+(fn Either.of [x] (Right:new x))
+
+(fn Right.map [self f] (Either.of (f self.value)))
+(fn Left.map [self f] self)
+
+{
+ : Either
+ : Left
+ : Right
+}
diff --git a/lib/either.test.fnl b/lib/either.test.fnl
new file mode 100644
index 0000000..fc819dc
--- /dev/null
+++ b/lib/either.test.fnl
@@ -0,0 +1,40 @@
+(local {: pprint} (require :lib.tableprint))
+
+(let [{
+       : Either
+       : Left
+       : Right
+       } (require :lib.either)]
+
+  ;; either
+  ;(print "Either Inspection")
+  ;(pprint Either)
+
+  ;; you can set and get values
+  (let [ v :poop x (Either:new v)]
+    (assert (= v x.value) (.. "The value is " v)))
+
+  (let [r (Right:new "rain")
+        map (r:map #(.. "b" $1))
+        expected :brain
+        actual (. map :value)
+        ]
+    (assert (= expected actual) "You can map a Right value"))
+
+  (let [l (Left:new "rain")
+        map (l:map #(.. "b" $1))
+        expected :rain
+        actual (. map :value)
+        ]
+    (assert (= expected actual) "You can NOT map a Left value"))
+
+  (let [e (Either.of "rank")
+        map (e:map #(.. "f" $1))
+        expected :frank
+        actual (. map :value)
+        ]
+    (assert (= expected actual) "You can map a Either.of"))
+
+
+
+)
diff --git a/lib/head.fnl b/lib/head.fnl
new file mode 100644
index 0000000..ddee698
--- /dev/null
+++ b/lib/head.fnl
@@ -0,0 +1,6 @@
+; return the first item in a table
+(fn head [t] (if (> (length t) 0)
+               (?. t 1)
+               []))
+
+{: head}
diff --git a/lib/head.test.fnl b/lib/head.test.fnl
new file mode 100644
index 0000000..7514121
--- /dev/null
+++ b/lib/head.test.fnl
@@ -0,0 +1,11 @@
+(let [{: head } (require :lib.head)]
+  (let [given "a lift of elements"
+        it "returns the first element of a list"
+        expected :apple
+        actual (head [:apple :orange :pear])]
+    (assert (= actual expected) (.. "Given " given " it " it)))
+  (let [given "an empty list"
+        it "returns an empty list"
+        expected 0
+        actual (length (head []))]
+    (assert (= actual expected) (.. "Given " given " it " it))))
diff --git a/lib/index.fnl b/lib/index.fnl
new file mode 100644
index 0000000..4d15b9a
--- /dev/null
+++ b/lib/index.fnl
@@ -0,0 +1,13 @@
+(local {:contains contains} (require :lib.contains))
+(local {:head head} (require :lib.head))
+(local {:mill? mill?} (require :lib.mill))
+(local {:pprint pprint} (require :lib.tableprint))
+(local {:tail tail} (require :lib.tail))
+
+{
+ :contains contains
+ :head head
+ :mill? mill?
+ :pprint pprint
+ :tail tail
+ }
diff --git a/lib/mill.fnl b/lib/mill.fnl
new file mode 100644
index 0000000..de54128
--- /dev/null
+++ b/lib/mill.fnl
@@ -0,0 +1,16 @@
+(local {: contains} (require :lib.contains))
+
+;; Does this move result in a mill?
+(fn mill? [rules state move]
+  (let [candidates (icollect [_ mill (ipairs rules)] (if (contains mill move) mill))
+        candidate->moves (icollect [_ spaces (ipairs candidates)]
+                                  (icollect [_ space (ipairs spaces)] (. state space)) )
+        candidate-mill? (icollect [_ moves (ipairs candidate->moves)]
+                                  (accumulate [acc true
+                                              idx m (ipairs moves)]
+                                              (and acc (not= 0 m) (= (. moves idx) m)))) ]
+    (accumulate [acc true
+                 _ x (ipairs candidate-mill?)]
+                (and acc x))))
+
+{: mill?}
diff --git a/lib/mill.test.fnl b/lib/mill.test.fnl
new file mode 100644
index 0000000..358b218
--- /dev/null
+++ b/lib/mill.test.fnl
@@ -0,0 +1 @@
+;; TODO: test me
diff --git a/lib/tableprint.fnl b/lib/tableprint.fnl
new file mode 100644
index 0000000..4d9bfbe
--- /dev/null
+++ b/lib/tableprint.fnl
@@ -0,0 +1,7 @@
+; print a table
+(fn pprint [tbl]
+  (each [k v (pairs tbl)]
+    (let [table? (= (type v) :table)]
+      (print k v))))
+
+{: pprint}
diff --git a/lib/tail.fnl b/lib/tail.fnl
new file mode 100644
index 0000000..24de254
--- /dev/null
+++ b/lib/tail.fnl
@@ -0,0 +1,7 @@
+; return the table minus the head
+(fn tail [t]
+  (icollect [i v (ipairs t)]
+            (if (> i 1)
+              v)))
+
+{: tail}
diff --git a/lib/tail.test.fnl b/lib/tail.test.fnl
new file mode 100644
index 0000000..358b218
--- /dev/null
+++ b/lib/tail.test.fnl
@@ -0,0 +1 @@
+;; TODO: test me
diff --git a/main.fnl b/main.fnl
new file mode 100644
index 0000000..169f4f9
--- /dev/null
+++ b/main.fnl
@@ -0,0 +1,282 @@
+; Introducing:
+; Nine Mens Morris
+; The Game
+;
+; Featuring:
+; Fennel
+; The Language
+;
+; By:
+; dozens
+; the human
+;
+; Do you know what Nine Mens Morris looks like?
+; It has three concentric rings, each containing eight spaces.
+; Here's what it looks like:
+;
+; 1-----2-----3
+; |     |     |
+; | 4---5---6 |
+; | |   |   | |
+; | | 7-8-9 | |
+; | | |   | | |
+; 0-1-2   3-4-5  +10
+; | | |   | | |
+; | | 6-7-8 | |
+; | |   |   | |
+; | 9---0---1 |  +20
+; |     |     |
+; 2-----3-----4
+
+
+;; helper and utility functions
+(local {
+  :contains contains
+  :head head
+  :mill? mill-maker
+  :pprint pprint
+  } (require :lib.index))
+
+
+; there are three phases of play:
+; placing, moving, and flying.
+; (plus one for capturing)
+; (plus one for complete)
+(local stages {
+  :placing  1
+  :moving   2
+  :flying   3
+  :capture  4
+  :complete 5
+})
+
+
+; there are two players
+; their names are LUIGI and MARIO
+(local player {
+  :one 1 ;; luigi
+  :two 2 ;; mario
+})
+
+
+; initialize moves[] to 0.
+; this is the game state.
+; shows which spaces are occupied by which players.
+; 0 = unoccupied
+; 1 = Player 1
+; 2 = Player 2
+(local moves (fcollect [i 1 24] 0))
+
+
+(local rules {
+; what moves are legal from each space
+; slash what neighbors does each space have
+  :neighbors [
+    [1 2 10]
+    [2 1 3 5]
+    [3 2 15]
+    [4 5 11]
+    [5 2 4 6 8]
+    [6 5 14]
+    [7 8 12]
+    [8 5 7 9]
+    [9 8 13]
+    [10 1 11 22]
+    [11 4 10 12 19]
+    [12 7 11 16]
+    [13 9 14 18]
+    [14 6 13 15 21]
+    [15 3 14 24]
+    [16 12 17]
+    [17 16 18 20]
+    [18 13 17]
+    [19 11 20]
+    [20 17 19 21 23]
+    [21 14 20]
+    [22 10 23]
+    [23 20 22 24]
+    [24 15 23]
+  ]
+; sixteen combinations of spaces form a mill
+  :mills [
+    [1 2 3]
+    [4 5 6]
+    [7 8 9]
+    [10 11 12]
+    [13 14 15]
+    [16 17 18]
+    [19 20 21]
+    [22 23 24]
+    [1 10 22]
+    [4 11 19]
+    [7 12 16]
+    [2 5 8]
+    [17 20 23]
+    [9 13 18]
+    [6 14 21]
+    [3 15 24]
+  ]
+})
+
+(fn mill? [state move] (partial mill-maker rules.mills))
+
+
+; game state object
+(local game {
+  :player player.one
+  :stage stages.placing
+  :update (fn [self move]
+             (if (mill? moves move)
+               (do
+                 (print "MILLLLLLLLLLLLL!")
+                 (tset self :stage stages.capture)
+                 )
+               (tset self :player (if (= player.one self.player) player.two player.one))
+               )
+             )
+})
+
+
+
+
+
+; This is what the game board looks like
+; it's also used to display the state of the game
+; the Xs are converted to "%d" later for string templating
+; they are Xs here so that it looks pretty =)
+(local board [
+  "  1 2 3 4 5 6 7"
+  "A x-----x-----x"
+  "  |     |     |"
+  "B | x---x---x |"
+  "  | |   |   | |"
+  "C | | x-x-x | |"
+  "  | | |   | | |"
+  "D x-x-x   x-x-x"
+  "  | | |   | | |"
+  "E | | x-x-x | |"
+  "  | |   |   | |"
+  "F | x---x---x |"
+  "  |     |     |"
+  "G x-----x-----x"
+])
+
+
+
+
+; Print! That! Board!
+(fn print-board [board moves]
+  (var total-count -2) ; lol,  m-a-g-i-c
+                       ; just kidding, it's so that -2 + 3 = 1
+                       ; which is where i want to start indexing my table
+  (each [_ row (ipairs board)]
+    (let [(template count) (string.gsub row "x" "%%d")]
+      (if (> count 0)
+        (do
+          (set total-count (+ total-count count)) ; where i need that magic number on first iteration
+          (print (string.format template (select total-count (table.unpack moves)))))
+        (print row)))))
+; `select` above does NOT do what i thought it did.
+; i thought it would return the first x values given (select x values)
+; instead it returns the rest of the table having discarded the first x values
+; i think that `pick-values` probably does what i thought `select` does
+
+
+; these are the only moves that are valid
+; i am somewhat bothered by all the wasted space
+; by 2-3A and 5-6A e.g.
+; Incidentally these are all in order of appearance
+; so when you find a match,
+; you can also update that index of `moves` to the current player number
+(local valid-spaces [
+  "1A" "4A" "7A"
+  "2B" "4B" "6B"
+  "3C" "4C" "5C"
+  "1D" "2D" "3D"
+  "5D" "6D" "7D"
+  "3E" "4E" "5E"
+  "2F" "4F" "5F"
+  "1G" "4G" "7G"
+])
+; add the inverse of each valid move
+; e.g. 1A = A1
+(fn add-reverse-moves []
+  (let [reversed (icollect [_ v (ipairs valid-spaces)] (string.reverse v))]
+    (each [_ v (ipairs reversed)]
+      (table.insert valid-spaces v))))
+(add-reverse-moves)
+
+
+; does the move exist within the domain of valid spaces
+(fn space-exists? [m] (contains valid-spaces (string.upper m)))
+
+; return the numerical index of a "A1" formatted move
+(fn index-of-move [m]
+    (let [ upper (string.upper m)
+           rev   (string.reverse upper)
+           idx   (head (icollect [i v (ipairs valid-spaces)]
+                         (if (or (= v upper) (= v rev)) i)))
+         ]
+         idx))
+
+; is the space represented by a move ("A1") unoccupied?
+(fn space-is-unoccupied? [m]
+  (let [unoccupied? 0]
+    (= unoccupied? (. moves (index-of-move m)))))
+
+; is this a legal move?
+; TODO: maybe some functional error handling here?
+;   https://mostly-adequate.gitbook.io/mostly-adequate-guide/ch08#pure-error-handling
+;   https://mostly-adequate.gitbook.io/mostly-adequate-guide/appendix_b#either
+; or maybe all i need is a case-try statement..
+;   https://fennel-lang.org/reference#case-try-for-matching-multiple-steps
+;   update: i didn't really like that
+; i think maybe i do want the monad after all..
+; i'll come back to it later
+(fn valid-move? [move]
+  (or
+    (and
+      (= stages.placing game.stage)
+      (or (space-exists? move) (print "That space does not exist!\nHint: 1a 1A A1 a1 are all valid moves."))
+      (or (space-is-unoccupied? move) (print "That space is occupied!"))))
+    (and
+      ;; TODO: add capturing phase
+      (= stages.capturing game.stage)
+      )
+    (and
+      ;; TODO: add flying phase
+      (= stages.flying game.stage)
+      )
+  )
+
+
+
+; get player input
+(fn get-move []
+  (print (.. "Player " game.player "'s turn:"))
+  (io.read))
+
+
+(fn main []
+  ;; game loop
+  (while (not (= game.stage stages.complete))
+    (print-board board moves)
+
+    ;; validation loop
+    (var is-valid false)
+    (var move "")
+    (while (not is-valid)
+      (set move (get-move))
+      (set is-valid (valid-move? move))
+      (if (not is-valid)
+        (print "Try again.")
+        (do
+          (print (.. "You chose " move))
+          (tset moves (index-of-move move) game.player)
+          (game:update move)
+          )
+      )
+    )
+  )
+)
+(main)
-- 
cgit 1.4.1-2-gfad0