From b09fb86a8d26ce874d738d3eb62da34dc4ea1516 Mon Sep 17 00:00:00 2001
From: "Samuel B. Johnson" <sabjohnso@yahoo.com>
Date: Wed, 6 Nov 2024 13:01:19 -0600
Subject: [PATCH] :white_check_mark: [bare-state] Add tests

Problem:
- The tests for the bare state monad are not sufficient.

Solution:
- Add additional tests
---
 src/bare-state.lisp       | 20 +++++++++++++++--
 test/bare-state-test.lisp | 46 +++++++++++++++++++++++++++++++++++++--
 2 files changed, 62 insertions(+), 4 deletions(-)

diff --git a/src/bare-state.lisp b/src/bare-state.lisp
index 08566a0..a600d28 100644
--- a/src/bare-state.lisp
+++ b/src/bare-state.lisp
@@ -5,10 +5,10 @@
   (:nicknames :bs)
   (:use :cl :contextual :contextual-derivation)
   (:export
-   #:bs-run
+   #:bs-run #:bs-exec #:bs-eval
    #:bs-fmap
    #:bs-pure #:bs-fapply #:bs-product
-   #:bs-mreturn #:bs-flatmap #:bs-flatten
+   #:bs-mreturn #:bs-flatmap #:bs-bind #:bs-flatten
    #:bs-mget #:bs-mput #:bs-select #:bs-modify
    #:let*-fun/bs #:let-fun/bs
    #:let-app/bs
@@ -23,6 +23,22 @@ returns the result of calling `MX' with `S'."
   (declare (type function mx))
   (funcall mx s))
 
+
+(defun bs-exec (s mx)
+  "Return the value from the running the the input stateful
+calculation, `MX' with the initial state `S'"
+
+  (declare (type function mx))
+  (car (bs-run s mx)))
+
+(defun bs-eval (s mx)
+  "Return the final state from the running the the input stateful
+calculation, `MX' with the initial state `S', ignoring the final value."
+
+  (declare (type function mx))
+  (cadr (bs-run s mx)))
+
+
 (defun bs-mreturn (x)
   "Wraps a value `X' in a state monad: returns a function that, when
 given a state `S', returns `X' alongside `S' in a 2-elment list."
diff --git a/test/bare-state-test.lisp b/test/bare-state-test.lisp
index 3bf21f2..638b29c 100644
--- a/test/bare-state-test.lisp
+++ b/test/bare-state-test.lisp
@@ -1,7 +1,7 @@
 (in-package :cl-user)
 
 (defpackage :contextual-bare-state-test
-  (:use :cl :fiveam :contextual :contextual-bare-state)
+  (:use :cl :fiveam :trivia :contextual :contextual-bare-state)
   (:export #:run-all-tests!))
 
 (in-package :contextual-bare-state-test)
@@ -27,7 +27,18 @@
   (is (equal '(s s) (bs-run 's (bs-mget))))
   (is (equal '("S" s) (bs-run 's (bs-select #'symbol-name))))
   (is (equal '(nil s1) (bs-run 's0 (bs-mput 's1))))
-  (is (equal '(nil "S") (bs-run 's (bs-modify #'symbol-name)))))
+  (is (equal '(nil "S") (bs-run 's (bs-modify #'symbol-name))))
+  (let ((s0 '((x . 1) (y . 2))))
+           (flet ((by-key (k) (lambda (s) (cdr (assoc k s0)))))
+             (is (equal (list 3 s0)
+                        (bs-run s0
+                          (bs-bind
+                           (bs-select (by-key 'x))
+                           (lambda (x)
+                             (bs-bind
+                              (bs-select (by-key 'y))
+                              (lambda (y)
+                                (bs-mreturn (+ x y))))))))))))
 
 
 (defmacro show (expr)
@@ -105,3 +116,34 @@
                      (let-app/bs ((x (bs-select (by-key 'x)))
                                   (y (bs-select (by-key 'y))))
                        (+ x y)))))))))
+
+
+;; Update the state of a game base on the input. The state is a tripple
+;; with a flag indicating if it is `ON' or `OFF' followed by the score
+;; for `A' and followed by the score for `B'.  Valid inputs are one of
+;; the symbol `A', `B', `ON' or `OFF'. Invalid inputs are just ignored
+;; and the state is
+(defun update-state (input)
+  (lambda (state)
+    (match (list input state)
+           ((list 'on  (list 'off a b)) (list 'on  a b))
+           ((list 'off (list 'on  a b)) (list 'off a b))
+           ((list 'a   (list 'on  a b)) (list 'on  (1+ a) b))
+           ((list 'b   (list 'on  a b)) (list 'on  a (1+ b)))
+           ((list _ state) (format t "~s" `(:input ,input :state ,state)) state))))
+
+;; Construct the stateful computation of a game based on the input listn
+(defun game (inputs)
+  (declare (type list inputs))
+  (if (null inputs) (bs-mreturn nil)
+      (destructuring-bind (input . more-inputs) inputs
+        (progn-mon/bs
+          (bs-modify (update-state input))
+          (game more-inputs)))))
+
+(test game
+  (let ((initial-state '(off 0 0)))
+    (is (eq nil (bs-exec initial-state (game '(on)))))
+    (is (equal '(on 0 0) (bs-eval initial-state (game '(on)))))
+    (is (equal '(off 1 0) (bs-eval initial-state (game '(on a off)))))
+    (is (equal '(off 2 1) (bs-eval initial-state (game '(on a b a off)))))))