✨ [comonad] Contextual has some support for comonads

Problem:
- Contextual does not provide any functions for working with comonads,
even though it has trivial contexts, which should be comonads, in
addition to monads.

Solution:
- Add the functions `EXTRACT`, `DUPLICATE` and `EXTEND`.
- Add the class `COMONAD-OPERATORS` and add it as another base class
of `TRIVIAL-OPERATORS`.

src/contextual.lisp

@@ -7,17 +7,21 @@
    #:pure #:fapply #:product
    #:mreturn #:flatmap #:flatten
    #:wrap #:unwrap
+   #:extract #:duplicate #:extend
+   #:expel
 
    #:fmap-func
    #:pure-func #:fapply-func #:product-func
    #:flatmap-func #:flatten-func
    #:wrap-func #:unwrap-func
+   #:extract-func #:duplicate-func #:extend-func
    #:let*-fun #:let-fun #:let-app #:let*-mon #:let-mon
    #:lift #:lift2 #:lift3 #:lift4 #:lift5 #:lift6 #:lift7
 
    #:functor-operators
    #:applicative-operators
    #:monad-operators
+   #:comonad-operators
    #:trivial-operators
 
    #:ctx-run))
@@ -33,6 +37,9 @@
 (defgeneric flatten-func (context))
 (defgeneric wrap-func    (context))
 (defgeneric unwrap-func  (context))
+(defgeneric extract-func (context))
+(defgeneric duplicate-func (context))
+(defgeneric extend-func (context))
 
 (defun ask-fmap ()
   (ctx-asks #'fmap-func))
@@ -61,6 +68,15 @@
 (defun ask-unwrap ()
   (ctx-asks #'unwrap-func))
 
+(defun ask-extract ()
+  (ctx-asks #'extract-func))
+
+(defun ask-duplicate ()
+  (ctx-asks #'duplicate-func))
+
+(defun ask-extend ()
+  (ctx-asks #'extend-func))
+
 (defun fmap (f cmx)
   "Given a function and an embelished value, return a
 contexual expression with the embellishment of the result
@@ -143,6 +159,33 @@ stripped from the input, which has multiple layers of embellishment."
                 (mx (ctx-injest cmx)))
     (funcall unwrap mx)))
 
+(defun extract (cwx)
+  "Return a contextual expression extracting the value from the embellishment."
+  (let-app/ctx ((extract (ask-extract))
+                (wx (ctx-injest cwx)))
+    (funcall extract wx)))
+
+(defun expel (ctx cwx)
+  (ctx-run ctx (extract cwx)))
+
+(defun duplicate (cwx)
+  "Return a contextual expression with the context's embellishment duplicated on the input"
+  (let-app/ctx ((duplicate (ask-duplicate))
+                (wx (ctx-injest cwx)))
+    (funcall duplicate wx)))
+
+(defun extend (f cwx)
+  "Return a contextual expression with the context's embellishment extended back over
+the value extracted from the embellishment."
+  (let-app/ctx ((ctx (ctx-ask))
+                (extend (ask-extend))
+                (wx (ctx-injest cwx)))
+    (funcall extend (lambda (wx)
+                      (let ((result (funcall f wx)))
+                        (if (contextual-p result)
+                            (ctx-run ctx result)
+                            result)))
+             wx)))
 
 (defmacro let*-fun (((var expr) &rest more-bindings) body &body more-body)
   (make-sequential-functor-binding
@@ -368,7 +411,46 @@ not occur in the arguments, return `NIL'."
 
   (call-next-method))
 
-(defclass trivial-operators (monad-operators)
+(defclass comonad-operators (functor-operators)
+  ((extract :initarg :extract :type function :reader extract-func)
+   (duplicate :initarg :duplicate :type function :reader duplicate-func)
+   (extend :initarg :extend :type function :reader extend-func)))
+
+(defmethod initialize-instance ((obj comonad-operators) &rest args)
+  (let ((extract (get-argument-or-slot-value args :extract obj 'extract)))
+    (if extract
+        (setf (slot-value obj 'extract) extract)
+        (error "`EXTRACT' was not provided and could not be derived fro `TRIVIAL-OPERATORS'")))
+
+  (let ((extend (get-argument-or-slot-value args :extend obj 'extend)))
+    (if extend
+        (setf (slot-value obj 'extend) extend)
+        (let ((fmap (get-argument-or-slot-value args :fmap obj 'fmap))
+              (duplicate (get-argument-or-slot-value args :duplicate obj 'duplicate)))
+          (if (and fmap duplicate)
+              (setf (slot-value obj 'extend)
+                    (lambda/duplicate-to-extend :duplicate duplicate :fmap fmap))))))
+
+  (let ((duplicate (get-argument-or-slot-value args :duplicate obj 'duplicate)))
+    (if duplicate (setf (slot-value obj 'duplicate) duplicate)
+        (let ((extend (get-argument-or-slot-value args :extend obj 'extend)))
+          (setf (slot-value obj 'duplicate)
+                (lambda/extend-to-duplicate :extend extend)))))
+
+  (let ((extend (get-argument-or-slot-value args :extend obj 'extend))
+        (extract (get-argument-or-slot-value args :extract obj 'extract)))
+    (setf (slot-value obj 'fmap)
+          (lambda (f wx)
+            (funcall extend (lambda (wx) (funcall f (funcall extract wx))) wx))))
+
+  (call-next-method)
+
+  (assert (slot-value obj 'fmap))
+  (assert (slot-value obj 'extract))
+  (assert (slot-value obj 'duplicate))
+  (assert (slot-value obj 'extend)))
+
+(defclass trivial-operators (monad-operators comonad-operators)
   ((wrap :initarg :wrap :type function :reader wrap-func)
    (unwrap :initarg :unwrap :type function :reader unwrap-func)))
 
@@ -378,28 +460,38 @@ not occur in the arguments, return `NIL'."
     (if wrap
         (setf (slot-value obj 'wrap) wrap)
         (let ((mreturn (get-argument-or-slot-value args :mreturn obj 'mreturn))
-              (pure (get-argument-or-slot-value args :pure obj 'pure)))
-          (if (or mreturn pure)
-              (setf (slot-value obj 'wrap) (or mreturn pure))
+              (pure (get-argument-or-slot-value args :pure obj 'pure))
+              (duplicate (get-argument-or-slot-value args :duplicate obj 'duplicate)))
+          (if (or mreturn pure duplicate)
+              (setf (slot-value obj 'wrap) (or mreturn pure duplicate))
               (error "`WRAP' was not provided and cannot be derived for `TRIVIAL-OPERATORS'")))))
 
   (let ((unwrap (get-argument-or-slot-value args :unwrap obj 'unwrap)))
     (if unwrap
         (setf (slot-value obj 'unwrap) unwrap)
-        (let ((flatten (get-argument-or-slot-value args :flatten obj 'flatten)))
-          (if flatten
-              (setf (slot-value obj 'unwrap) flatten)
+        (let ((flatten (get-argument-or-slot-value args :flatten obj 'flatten))
+              (extract (get-argument-or-slot-value args :extract obj 'extract)))
+          (if (or flatten extract)
+              (setf (slot-value obj 'unwrap) (or flatten extract))
               (error "`UNWRAP' was not provided and cannot be derived for `TRIVIAL-OPERATORS'")))))
 
   (setf (slot-value obj 'mreturn) (slot-value obj 'wrap))
   (setf (slot-value obj 'pure) (slot-value obj 'wrap))
+  (setf (slot-value obj 'duplicate) (slot-value obj 'wrap))
+
   (setf (slot-value obj 'flatten) (slot-value obj 'unwrap))
+  (setf (slot-value obj 'extract) (slot-value obj 'unwrap))
 
   (setf (slot-value obj 'fmap)
         (lambda/wrap-and-unwrap-to-fmap
          :wrap (slot-value obj 'wrap)
          :unwrap (slot-value obj 'unwrap)))
 
+  (let ((wrap (slot-value obj 'wrap)))
+    (setf (slot-value obj 'extend)
+          (lambda (f wx)
+            (funcall wrap (funcall f wx)))))
+
   (assert (slot-boundp obj 'wrap))
   (assert (slot-boundp obj 'unwrap))
   (assert (slot-boundp obj 'flatten))

src/derivation.lisp

@@ -10,8 +10,9 @@
    #:defun/flatmap-to-fapply       #:lambda/flatmap-to-fapply
    #:defun/fapply-to-product       #:lambda/fapply-to-product
    #:defun/product-to-fapply       #:lambda/product-to-fapply
-   #:defun/fapply-to-fmap          #:lambda/fapply-to-fmap))
-
+   #:defun/fapply-to-fmap          #:lambda/fapply-to-fmap
+   #:defun/duplicate-to-extend     #:lambda/duplicate-to-extend
+   #:defun/extend-to-duplicate     #:lambda/extend-to-duplicate))
 (in-package :contextual-derivation)
 
 (defmacro with-syms ((&rest names) &body body)
@@ -143,3 +144,117 @@ from the named functions `FAPPLY' and `PURE'."
  from `FAPPLY' and `PURE'."
   (lambda (f mx)
     (funcall fapply (funcall pure f) mx)))
+
+
+
+
+(defmacro defun/duplicate-to-extend (name &key duplicate fmap documentation)
+  "Defines a function `NAME' that prefoms a comonadic mapping operation.
+
+The resulting function will take two arguments: `F', the function to map,
+and `WX', the comonadic input, which will be duplicated before mapping.
+The defined function uses the provided comonadic duplicate and fmap functions
+name by the inputs `DUPLICATE` and `FMAP`.
+
+Parameters:
+  NAME           - The name of the function to define.
+  :DUPLICATE     - The name of the comonadic duplciate function for the context.
+  :FMAP          - The name of the functorial mapping function for the context.
+  :DOCUMENTATION - Optional Documentation for the defined function.
+"
+  (assert duplicate)
+  (assert fmap)
+
+  (let ((documentation (if documentation (list documentation) documentation)))
+    (with-syms (f wx)
+      `(defun ,name (,f ,wx)
+         ,@documentation
+         (,fmap ,f (,duplicate ,wx))))))
+
+(defun lambda/duplicate-to-extend (&key duplicate fmap)
+  "Creates a lambda function that performs a comonadic 'extend' operation.
+
+This function constructs and returns an anonymous function (lambda) that
+takes a function `F' and a comonadic context `WX', and then performs an
+extend-like operation by:
+  1. Duplicating the context `WX' using the provided `DUPLICATE' function.
+  2. Mapping `F' over the duplicated context using the provided `FMAP' function.
+
+Parameters:
+  :DUPLICATE - A function that duplicates the comonadic context `WX'.
+  :FMAP      - A function that maps `F' over elements in the duplicated
+               context.
+
+Usage:
+  This returned lambda function can be applied to a function `F' and a
+  comonadic context `WX' to perform comonadic mapping.
+
+Example:
+  (let ((extend-fn (lambda/duplicate-to-extend :duplicate duplicate-fn :fmap fmap-fn)))
+    (funcall extend-fn some-function some-context))"
+  (flet ((duplicate (wx) (funcall duplicate wx))
+         (fmap (f wx) (funcall fmap f wx)))
+    (lambda (f wx)
+      (fmap f (duplicate wx)))))
+
+
+(defmacro defun/extend-to-duplicate (name &key extend documentation)
+  "Defines a function `NAME` that duplicates a comonadic context using an 'extend' function.
+
+This macro generates a function that takes a single argument `WX` and applies
+the `EXTEND` function to it with an identity transformation, effectively duplicating
+the comonadic context. This is useful in comonadic programming where duplicating
+or 'extending' the context is required to perform further operations.
+
+Parameters:
+  NAME           - The name of the function to define. Must be a symbol.
+  :EXTEND        - A function that takes a transformation function and the comonadic
+                   context `WX`, and applies the transformation across the context.
+                   Must be a symbol.
+  :DOCUMENTATION - An optional string describing the purpose or behavior of the
+                   generated function, added as a docstring.
+
+Example Usage:
+  (defun/extend-to-duplicate my-duplicate :extend extend-fn :documentation \"Duplicates the context using extend-fn\")
+
+This will create a function `my-duplicate` that takes a comonadic context `WX`
+and returns a duplicated context by applying `extend-fn` with an identity transformation."
+
+  (assert (symbolp name))
+  (assert (symbolp extend))
+  (assert (or (null documentation)
+              (stringp documentation)))
+
+  (let ((documentation (if documentation (list documentation) nil)))
+    (with-syms (wx)
+      `(defun ,name (,wx)
+         ,@documentation
+         (,extend (lambda (,wx) ,wx) ,wx)))))
+
+
+
+(defun lambda/extend-to-duplicate (&key extend)
+  "Creates a lambda function that perfoms a comonadic 'duplicate' operation using an 'extend' function.
+
+This function constructs and returns an anonymous function (lambda) that,
+when given a comonadic context `WX', applies an extend-like operation to
+produce a duplicated context. It effectively uses the `EXTEND' function to
+create a new context containing the original context at each level.
+
+Parameters:
+  :EXTEND - A function that performs comonadic mapping to the comonadic context `WX'.
+
+Usage:
+  The returned lambda function can be used to duplicate a comonadic
+  structure by.
+
+Example:
+  (let ((duplicate-fn (lambda/extend-to-duplicate :extend extend-fn)))
+    (funcall duplicate-fn some-context))
+
+This will return a duplicated context by applying the `EXTEND' function
+to `some-context' with an identity function."
+  (assert (functionp extend))
+  (flet ((extend (f wx)
+           (funcall extend f wx)))
+    (lambda (wx) (extend (lambda (wx) wx) wx))))

test/contextual-test.lisp

@@ -89,7 +89,7 @@
     (is (equalp (make-id :value 9) (ctx-run context (flatmap #'sqr-id (pure 3)))))
     (is (equalp (make-id :value 3) (ctx-run context (flatten (pure (pure 3))))))))
 
-(test trivial-context
+(test trivial-context-pure-and-flatten
   (let ((context
           (make-instance 'trivial-operators
             :pure (lambda (x) (make-id :value x))
@@ -105,9 +105,65 @@
     (is (equalp (make-id :value 9) (ctx-run context (fmap #'sqr (pure 3)))))
     (is (equalp (make-id :value 9) (ctx-run context (fapply (pure #'sqr) (pure 3)))))
     (is (equalp (make-id :value 9) (ctx-run context (flatmap #'sqr-id (pure 3)))))
-    (is (equalp (make-id :value 3) (ctx-run context (flatten (pure (pure 3))))))))
+    (is (equalp (make-id :value 3) (ctx-run context (flatten (pure (pure 3))))))
+    (is (equalp 3 (ctx-run context (extract (pure 3)))))
+    (is (equalp (make-id :value 3) (ctx-run context (extend #'extract (pure 3)))))
+    (is (equalp (make-id :value 3) (ctx-run context (extend #'extract (make-id :value 3)))))
+    (is (equalp (make-id :value (make-id :value 3))
+                (ctx-run context
+                  (duplicate (pure 3)))))
+    (is (equalp 3 (expel context (pure 3))))))
+
+(test trivial-context-pure-and-extract
+  (let ((context
+          (make-instance 'trivial-operators
+            :pure (lambda (x) (make-id :value x))
+            :extract (lambda (mx) (id-value mx)))))
+    (is-true (typep context 'trivial-operators))
+    (is-true (typep context 'monad-operators))
+    (is-true (typep context 'applicative-operators))
+    (is-true (typep context 'functor-operators))
+    (is (equalp (make-id :value 3) (ctx-run context (pure 3))))
+    (is (equalp (make-id :value 3) (ctx-run context (mreturn 3))))
+    (is (equalp (make-id :value 3) (ctx-run context (wrap 3))))
+    (is (equalp 3 (ctx-run context (unwrap (pure 3)))))
+    (is (equalp (make-id :value 9) (ctx-run context (fmap #'sqr (pure 3)))))
+    (is (equalp (make-id :value 9) (ctx-run context (fapply (pure #'sqr) (pure 3)))))
+    (is (equalp (make-id :value 9) (ctx-run context (flatmap #'sqr-id (pure 3)))))
+    (is (equalp (make-id :value 3) (ctx-run context (flatten (pure (pure 3))))))
+    (is (equalp 3 (ctx-run context (extract (pure 3)))))
+    (is (equalp (make-id :value 3) (ctx-run context (extend #'extract (pure 3)))))
+    (is (equalp (make-id :value 3) (ctx-run context (extend #'extract (make-id :value 3)))))
+    (is (equalp (make-id :value (make-id :value 3))
+                (ctx-run context
+                  (duplicate (pure 3)))))))
 
+(test comonad-context-with-duplicate
+  (let ((context
+          (make-instance 'comonad-operators
+            :fmap (lambda (f wx) (cons (funcall f (car wx))
+                                       (cdr wx)))
+            :extract #'car
+            :duplicate (lambda (wx)
+                         (cons wx (cdr wx))))))
+    (is (equal (ctx-run context
+                 (extend (lambda (wx) (sqr (car wx))) `(3 . 4)))
+               `(9 . 4)))
+    (is (equal 3 (ctx-run context
+                   (extract '(3 . 4)))))
+    (is (equal '((3 . 4) . 4)
+               (ctx-run context
+                 (duplicate `(3 . 4)))))))
 
+(test comonad-context-with-extend
+  (let ((context
+          (make-instance 'comonad-operators
+            :extract #'car
+            :extend (lambda (f wx)
+                      (cons (funcall f wx) (cdr wx))))))
+    (is (equal (ctx-run context (extend (lambda (wx) (sqr (car wx))) `(3 . 4))) `(9 . 4)))
+    (is (equal 3 (ctx-run context (extract '(3 . 4)))))
+    (is (equal '((3 . 4) . 4) (ctx-run context (duplicate `(3 . 4)))))))
 
 (defun rappend (xs ys)
   (labels ((recur (xs accum)
@@ -441,4 +497,10 @@
               :pure #'repeat
               :product #'ziplist-product))
 
-  (is-error (make-instance 'functor-operators)))
+  (is-error (make-instance 'functor-operators))
+
+  (is-error (make-instance 'comonad-operators))
+  (is-error (make-instance 'comonad-operators :extract #'funcall))
+
+  (is-error (make-instance 'comonad-operators :extract #'funcall :duplicate #'list))
+  (is-error (make-instance 'comonad-operators :extend (lambda (f wx) (funcall f wx)))))