1: L99-problem27.lisp

;;;;===================================================================
;;;; L99 problem 27

;;;; as a result, it is similar to one in www.informatimago.com/develop/lisp/l99/

(defun comb (n r xs)
  (cond ((or (zerop r) (null xs)) '(()))
        ((= n r) (list (copy-seq xs)))
        (t
         (destructuring-bind (kar . kdr) xs
           (nconc (comb (1- n) r kdr)
                  (mapcons kar (comb (1- n) (1- r) kdr)))))))

(defun combinations (r xs &aux (n (length xs)))
  (assert (>= n r 0))
  (assert (listp xs))
  (comb n r xs))

(defun lcurry  (f a)   (lambda (b) (funcall f a b)))
(defun mapcons (x yss) (mapcar (lcurry #'cons x) yss))

(defun group (set sizes)
  (cond ((null sizes) '(()))
        ((null set)   (error "group"))
        (t
         (mapcan (lambda (subgrp)
                   (mapcons subgrp
                            (group (set-difference set subgrp) (cdr sizes))))
                 (combinations (car sizes) set)))))

2: L99-problem27-ocamlport.lisp

;;;;===================================================================
;;;; L99 problem 27
;;;; (ported from #27 in https://ocaml.org/learn/tutorials/99problems.html)

;; OCaml uses currying often, so the followings are useful for porting.
(defun lcurry (f a) (lambda (b) (funcall f a b)))
(defun rcurry (f b) (lambda (a) (funcall f a b)))

;; For readability, we introduce type PAIR and PRINT-OBJECT for 2-item tuple,
;; instead of CONS, i.e. replace the following definitions:
;;  (defun pair    (x y) (cons x y))
;;  (defun pair-fst  (p) (car p))
;;  (defun pair-snd  (p) (cdr p))
(defstruct pair  fst snd)
(defun pair (n l) (make-pair :fst n :snd l))

(defun zero-fst? (p) (zerop (pair-fst p)))
(defmethod print-object ((obj pair) stream)
  ;; readily percetiable than CONS when tracing
  (format stream "[~s,~s]" (pair-fst obj) (pair-snd obj))
  obj)

;; Replace CL idioms to other names, i.e. more common in other languages.
(defun filter     (fn xs) (remove-if-not fn xs))
(defun concat-map (fn xs) (apply #'append (mapcar fn xs)))

;;;

(defvar *break-in-prepend* nil)

(defun emit (l acc)
  (when *break-in-prepend* (break "emit"))
  (cons l acc))

;; PREPEND, the core of the solution, accepts a LIST of groups,
;; each with the NUMBER of items that should be added,
;; and prepends the item P to every group that can support it,
;; thus prepending P for ([1,(a)] [2,(b)] [0,(c)]) turns the LIST into
;; (([0,(p a)][2,(b)][0,(c)])([1,(a)][1,(p b)][0,(c)])([1,(a)][2,(b)][0,(c)])).
(defun prepend-demo ()
  ;; meant to be called with (TRACE PREPEND)
  (let ((*break-in-prepend* t)
        (data (list (pair 1 `(a)) (pair 2 `(b)) (pair 0 `(c)))))
    (print data)
    (terpri)
    (prepend 'p data)))

(defun prepend (p list)
  (labels ((aux (fn acc xs)
             (if (null xs)
               (progn
                 (when *break-in-prepend* (break "hoge"))
                 (funcall fn '() acc))
               (destructuring-bind (hd . tl) xs
                 (let ((n (pair-fst hd)) (l (pair-snd hd)))
                   (aux (lambda (l acc) (funcall fn (cons hd l) acc))
                        (if (plusp n)
                          (funcall fn (cons (pair (1- n) (cons p l))
                                            tl)
                                   acc)
                          acc)
                        tl))))))
    (aux #'emit '() list)))

(defun group (xs sizes)
  (let ((initial (mapcar (rcurry #'pair '()) sizes)))
    (labels ((aux (xs)
               (if (null xs)
                 (list initial)
                 (concat-map (lcurry #'prepend (car xs))
                             (aux (cdr xs))))))
      ;; Don't forget to eliminate all group sets that have non-full groups
      (mapcar (lcurry #'mapcar #'pair-snd)
              (filter (lcurry #'every #'zero-fst?) (aux xs))))))

;; trial expressions
;;   (group '(a b)       '(1))
;;   (group '(a b c)     '(2))
;;   (group '(a b c d)   '(2 1))
;;   (group '(a b c d e) '(2 1 2) )

;; L99 problem27
;;   (group '(a b c d e f g h i) '(2 3 4))

;;;-------------------------------------------------------------------
;;; debugging staff (since SBCL doesn't support local function tracing)

(defvar *initial* nil)

(defun g-aux (xs)
  (if (null xs)
    (list *initial*)
    (destructuring-bind (a . d) xs
      (concat-map (lcurry #'prepend a) (g-aux d)))))

;; Tracing GROUP-FOR-TRACE w/ the following setting is good for understanding:
;;   (TRACE GROUP-FOR-TRACE G-AUX CONCAT-MAP PREPEND)
;; Tracing only PREPEND is also good.
(defun group-for-trace (xs sizes)
  (setq *initial* (mapcar (rcurry #'pair '()) sizes))
  (let* ((all (g-aux xs))
         (complete (filter (lcurry #'every #'zero-fst?) all))
         (snd-only (mapcar (lcurry #'mapcar #'pair-snd) complete)))
    (values all complete snd-only) ))

3: prepend-demo-trace.txt

;; PREPEND, the core of the solution, accepts a LIST of groups,
;; each with the NUMBER of items that should be added,
;; and prepends the item P to every group that can support it,
;; thus prepending P for ([1,(a)] [2,(b)] [0,(c)]) turns the LIST into
;; (([0,(p a)][2,(b)][0,(c)])([1,(a)][1,(p b)][0,(c)])([1,(a)][2,(b)][0,(c)])).
(defun prepend-demo ()
  ;; meant to be called with (TRACE PREPEND)
  (let ((*break-in-prepend* t)
        (data (list (pair 1 `(a)) (pair 2 `(b)) (pair 0 `(c)))))
    (print data)
    (terpri)
    (prepend 'p data)))

;;;===================================================================

CL-USER> (prepend-demo)

([1,(A)] [2,(B)] [0,(C)]) 
  0: (PREPEND P ([1,(A)] [2,(B)] [0,(C)]))
  0: PREPEND returned
       (([1,(A)] [2,(B)] [0,(C)]) ([1,(A)] [1,(P B)] [0,(C)])
        ([0,(P A)] [2,(B)] [0,(C)]))
(([1,(A)] [2,(B)] [0,(C)]) ([1,(A)] [1,(P B)] [0,(C)])
 ([0,(P A)] [2,(B)] [0,(C)]))
CL-USER> 

;;;===================================================================

emit
   [Condition of type SIMPLE-CONDITION]

Restarts:
 0: [CONTINUE] Return from BREAK.
 1: [RETRY] Retry SLIME REPL evaluation request.
 2: [*ABORT] Return to SLIME's top level.
 3: [ABORT] abort thread (#<THREAD "repl-thread" RUNNING {1004928413}>)

Backtrace:
  0: (EMIT ([1,(A)] [2,(B)] [0,(C)]) (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)))
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        L = ([1,(A)] [2,(B)] [0,(C)])
  1: ((LAMBDA (L ACC) :IN PREPEND) ([2,(B)] [0,(C)]) (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)))
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        HD = [1,(A)]
        L = ([2,(B)] [0,(C)])
        SB-C::THING = #<FUNCTION EMIT>
  2: ((LAMBDA (L ACC) :IN PREPEND) ([0,(C)]) (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)))
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        HD = [2,(B)]
        L = ([0,(C)])
        SB-C::THING = #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {10056D433B}>
  3: ((LAMBDA (L ACC) :IN PREPEND) NIL (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)))
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        HD = [0,(C)]
        L = NIL
        SB-C::THING = #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {100589152B}>
  4: ((LABELS AUX :IN PREPEND) #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {1005A4952B}> (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)) NIL)
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        P = P
        SB-C::THING = #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {1005A4952B}>
        XS = NIL
  5: ((LABELS AUX :IN PREPEND) #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {100589152B}> (([1,#1=(A)] [1,(P . #2=#)] . #3=([0,#])) ([0,(P . #1#)] [2,#2#] . #3#)) ([0,(C)]))
      Locals:
        ACC = (([1,(A)] [1,(P B)] [0,(C)]) ([0,(P A)] [2,(B)] [0,(C)]))
        #:G0 = NIL
        HD = [0,(C)]
        L = (C)
        N = 0
        P = P
        SB-C::THING = #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {100589152B}>
        TL = NIL
        XS = ([0,(C)])
  6: ((LABELS AUX :IN PREPEND) #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {10056D433B}> (([0,(P A)] [2,(B)] [0,(C)])) ([2,(B)] [0,(C)]))
      Locals:
        ACC = (([0,(P A)] [2,(B)] [0,(C)]))
        #:G0 = ([0,(C)])
        HD = [2,(B)]
        L = (B)
        N = 2
        P = P
        SB-C::THING = #<CLOSURE (LAMBDA (L ACC) :IN PREPEND) {10056D433B}>
        TL = ([0,(C)])
        XS = ([2,(B)] [0,(C)])
  7: ((LABELS AUX :IN PREPEND) #<FUNCTION EMIT> NIL ([1,(A)] [2,(B)] [0,(C)]))
      Locals:
        ACC = NIL
        #:G0 = ([2,(B)] [0,(C)])
        HD = [1,(A)]
        L = (A)
        N = 1
        P = P
        SB-C::THING = #<FUNCTION EMIT>
        TL = ([2,(B)] [0,(C)])
        XS = ([1,(A)] [2,(B)] [0,(C)])
  8: (PREPEND P ([1,(A)] [2,(B)] [0,(C)]))
      Locals:
        LIST = ([1,(A)] [2,(B)] [0,(C)])
        P = P
  9: (SB-DEBUG::TRACE-CALL #<SB-DEBUG::TRACE-INFO PREPEND> #<FUNCTION PREPEND> P ([1,(A)] [2,(B)] [0,(C)]))
 10: (PREPEND-DEMO)
      Locals:
        DATA = ([1,(A)] [2,(B)] [0,(C)])
 11: (SB-INT:SIMPLE-EVAL-IN-LEXENV (PREPEND-DEMO) #<NULL-LEXENV>)
 12: (EVAL (PREPEND-DEMO))
 --more--