[PRL] Accumulator for container capacity

[Jesse A. Tov]

Since Matthias asked in a different thread about accumulators and 
monads, I thought it might be worth joining the two.  Here's a solution 
using the state monad in a straightforward manner:  The number of 
violations is carried by the implicit state, and there's one update to 
the state that corresponds to where Matthias used set!.  After that, 
there's a monadic version using Will's visitor/fold, and a second that 
uses the same container visitor/fold but avoids the double traversal by 
using foldl lifted into the state monad.  Finally, there's an 
"inside-out" version that keeps track of weight/capacity with the 
implicit state and explicitly returns the number of violations.

; Abstract over monads -- a monad is pair of operations, unit and bind:
(define-struct monad (unit bind))

;; Given that pair of operations, there are several other
;; monad operators we might want to define:

;; (sequence monad): list(monad(x))  ->  monad(list(x))
(define (sequence monad)
   (lambda (lom)
     (cond
       [(null? lom) ((monad-unit monad) '())]
       [else        ((monad-bind monad)
                     (car lom)
                     (lambda (v)
                       ((monad-bind monad)
                        ((sequence monad) (cdr lom))
                        (lambda (vs)
                          ((monad-unit monad) (cons v vs))))))])))

;; (map-m monad): list(a)  (a -> monad(b))  ->  monad(list(b))
(define (map-m monad)
   (lambda (f lov)
     ((sequence monad) (map f lov))))

;; (foldl-m monad): (a b -> monad(b))  b  list(a)  ->  monad(b)
(define (foldl-m monad)
   (lambda (f z lov)
     (cond
       [(null? lov) ((monad-unit monad) z)]
       [else        ((monad-bind monad)
                     (f z (car lov))
                     (lambda (z)
                       ((foldl-m monad) f z (cdr lov))))])))

;; Example: the list monad
(define (list-unit x)
   (list x))
(define (list-bind m k)
   (apply append (map k m)))
(define list-monad
   (make-monad list-unit list-bind))


;; The State Monad

;; Every step/action in the state monad is a function from a state to a
;; pair of result and state.  To run the state monad, we apply it to an
;; initial state:
;; sm-run:  sm(s, r)  s  ->  (r . s)
(define (sm-run sm s0)
   (sm s0))

;; Usually we'll use one of these instead:
;; sm-exec:  sm(s, r)  s  ->  s
;; sm-eval:  sm(s, r)  s  ->  r
(define (sm-eval sm s0)
   (car (sm-run sm s0)))
(define (sm-exec sm s0)
   (cdr (sm-run sm s0)))

;; sm-unit: r -> sm(s, r)
(define (sm-unit a)
   (lambda (s)
     (cons a s)))

;; sm-bind: sm(s, r1) (r1 -> sm(s, r2)) -> sm(s, r2)
(define (sm-bind m k)
   (lambda (s)
     (let ((r0 (sm-run m s)))
       (sm-run (k (car r0)) (cdr r0)))))

(define sm (make-monad sm-unit sm-bind))

;; State monad has two additional primitive operations:
;;   sm-get: sm(s, s); to read the state
;;   sm-put: s -> sm(s, '()); to write the state
(define (sm-get)
   (lambda (s)
     (cons s s)))

(define (sm-put s)
   (lambda (_)
     (cons '() s)))


;;;;; Here lies the abstraction barrier.

;; Map f over the state, return '().
;; sm-modify: (s -> s) -> sm(s, '())
(define (sm-modify f)
   (sm-bind
    (sm-get)
    (lambda (s)
      (sm-put (f s)))))


;; Okay, now we're ready.

;; From MF:
(define-struct Container (contents capacity))
(define-struct Simple (name weight))

(define c-1
   (make-Container (list
                    (make-Simple "apple" 1))
                   1))

(define c0
   (make-Container (list
                    (make-Simple "pencil" 1)
                    c-1
                    (make-Simple "orange" 1))
                   1))

(define c1
   (make-Container (list
                    (make-Simple "apple" 1)
                    c0
                    (make-Simple "orange" 1)
                    (make-Simple "kiwi" 1))
                   5))

(define (test-violations violations)
   (list
    (= (violations c-1) 0)
    (= (violations c0) 1)
    (= (violations c1) 2)))

;; Okay, here's something like Mitch's solution.  Each recursive call to
;; the auxiliary function returns a list containing the weight and 
violations
;; in that subcontainer.
(define (violations-direct c)
   ;; item -> (list weight violations)
   (define (w-and-v-item c)
     (cond
       [(Simple? c)    (list (Simple-weight c) 0)]
       [(Container? c) (w-and-v-container c)]))
   ;; container -> (list weight violations)
   (define (w-and-v-container c)
     (let
         ((nest (apply map + (map w-and-v-item (Container-contents c)))))
          (cond
            [(> (car nest) (Container-capacity c))
             (list (car nest) (+ 1 (cadr nest)))]
            [else nest])))
    (cadr (w-and-v-item c)))

'testing-violations-direct
(test-violations violations-direct)

;; Here's a pretty straightforward translation of that to the
;; state monad:
(define (violations-monadic c)
   ;; item -> sm(violations, weight)
   (define (weight-item c)
     (cond
       [(Simple? c)    (sm-unit (Simple-weight c))]
       [(Container? c) (weight-container c)]))
   ;; container -> sm(violations, weight)
   (define (weight-container c)
     (sm-bind
      ((map-m sm) weight-item (Container-contents c))
      (lambda (weights)
        (let ((weight (foldl + 0 weights)))
          (sm-bind
           (if (> weight (Container-capacity c))
               (sm-modify add1)
               (sm-unit '()))
           (lambda (_)
             (sm-unit weight)))))))
    (sm-exec (weight-item c) 0))

'testing-violations-monadic
(test-violations violations-monadic)

;; Will defines a fold over container trees, something like:
(define (make-item-visitor visit-simple visit-container)
   (define (visitor c)
     (cond
       [(Simple? c) (visit-simple (Simple-name c) (Simple-weight c))]
       [(Container? c)
        (visit-container (map visitor (Container-contents c))
                           (Container-capacity c))]))
   visitor)

;; We can the state monad with a fold:
(define (violations-monadic-visitor c)
   ;; name weight -> sm(violations, weight)
   (define (visit-simple name weight)
     (sm-unit weight))
   ;; list-of(sm(violations, weight)) capacity -> sm(violations, weight)
   (define (visit-container m-weights capacity)
     (sm-bind
      ((sequence sm) m-weights)
      (lambda (weights)
        (let ((weight (foldl + 0 weights)))
          (sm-bind
           (if (> weight capacity)
               (sm-modify add1)
               (sm-unit '()))
           (lambda (_)
             (sm-unit weight)))))))
   (sm-exec
    ((make-item-visitor visit-simple visit-container) c)
    0))

'testing-violations-monadic-visitor
(test-violations violations-monadic-visitor)


;; If we really want "one pass", we might get what we wish for (eww!):
(define (violations-monadic-visitor-1pass c)
   ;; name weight -> sm(violations, weight)
   (define (visit-simple name weight)
     (sm-unit weight))
   ;; list-of(sm(violations, weight)) capacity -> sm(violations, weight)
   (define (visit-container m-weights capacity)
     (sm-bind
      ((foldl-m sm)
       (lambda (weight-so-far m-weight)
         (sm-bind
          m-weight
          (lambda (weight)
            (sm-unit (+ weight-so-far weight)))))
       0 m-weights)
      (lambda (weight)
        (sm-bind
         (if (> weight capacity)
             (sm-modify add1)
             (sm-unit '()))
         (lambda (_)
           (sm-unit weight))))))
   (sm-exec
    ((make-item-visitor visit-simple visit-container) c)
    0))

'testing-violations-monadic-visitor-1pass
(test-violations violations-monadic-visitor-1pass)


;; We can switch the state and the result -- that is, keep track of
;; capacity/weight in the state and explicity return the violations.
;; To do this, we're probably going to want to use the state as a
;; stack:
(define (sm-push v)
   (sm-bind
    (sm-get)
    (lambda (s)
      (sm-put (cons v s)))))
(define (sm-pop)
   (sm-bind
    (sm-get)
    (lambda (s)
      (sm-bind
       (sm-put (cdr s))
       (lambda (_)
         (sm-unit (car s)))))))

(define (violations-monadic-visitor-inside-out c)
   (define (visit-simple name weight)
     (sm-bind
      (sm-modify
       (lambda (stack)
         (map (lambda (capacity) (- capacity weight)) stack)))
      (lambda (_)
        (sm-unit 0))))
   (define (visit-container m-violations capacity)
     (sm-bind
      (sm-push capacity)
      (lambda (_)
        (sm-bind
         ((sequence sm) m-violations)
         (lambda (violations-list)
           (let ((violations (foldl + 0 violations-list)))
             (sm-bind
              (sm-pop)
              (lambda (capacity-remaining)
                (sm-unit (if (< capacity-remaining 0)
                             (+ 1 violations)
                             violations))))))))))
   (sm-eval
    ((make-item-visitor visit-simple visit-container) c)
    '()))

'testing-violations-monadic-visitor-inside-out
(test-violations violations-monadic-visitor-inside-out)

;; Jesse