advent-of-code-2022/day-11/part-02.scm

(import
 (except (rnrs base)
         let-values
         map
         error
         vector-map)
 (only (guile)
       lambda* λ
       simple-format
       current-output-port)
 (fileio)
 (queue)
 (list-helpers)
 (math)
 ;; lists
 (srfi srfi-1)
 ;; vectors
 (srfi srfi-43)
 ;; let-values
 ;; (srfi srfi-11)
 ;; hash tables
 ;; (srfi srfi-69)
 ;; functional records
 (srfi srfi-9 gnu)
 (ice-9 pretty-print)
 (ice-9 peg)
 (prefix (peg-tree-utils) peg-tree:))

;; define parser

(define-peg-pattern SPACE none " ")
(define-peg-pattern NEWLINE none "\n")
(define-peg-pattern COLON none ":")
(define-peg-pattern KEY-VAL-SEP none (and COLON SPACE))
(define-peg-pattern NUMBER body (+ (range #\0 #\9)))
(define-peg-pattern ANYTHING-EXCEPT-NUMBER none
  (* (and (not-followed-by NUMBER) peg-any)))

;; 1. line
(define-peg-pattern MONKEY-LABEL none "Monkey")
(define-peg-pattern ID all NUMBER)

;; 2. line
(define-peg-pattern NUMBER-LIST all (* (and NUMBER (? ",") (? SPACE))))
(define-peg-pattern ITEMS-LINE all (and ANYTHING-EXCEPT-NUMBER NUMBER-LIST))

;; 3. line
(define-peg-pattern OP-LABEL none "Operation")
(define-peg-pattern OP-VAR-NEW none "new")
(define-peg-pattern OP-EQUALS none "=")
(define-peg-pattern OP-VAR-OLD none "old")

(define-peg-pattern OPERATOR all (or "+" "*"))
(define-peg-pattern OPERAND-OLD body "old")
(define-peg-pattern OPERAND all (or NUMBER OPERAND-OLD))

(define-peg-pattern OPERATION all
  (and OPERATOR SPACE OPERAND))

(define-peg-pattern ID-LINE all
  (and MONKEY-LABEL SPACE ID COLON))

(define-peg-pattern OP-LINE all
  (and (* SPACE) OP-LABEL KEY-VAL-SEP
       OP-VAR-NEW SPACE OP-EQUALS SPACE OP-VAR-OLD SPACE
       OPERATION))

;; 4. line
(define-peg-pattern TEST-DIVISOR all NUMBER)
(define-peg-pattern TEST-LINE all (and ANYTHING-EXCEPT-NUMBER TEST-DIVISOR))

;; 5. line
(define-peg-pattern TEST-TRUE-NEXT-MONKEY all NUMBER)
(define-peg-pattern TEST-TRUE-LINE all (and ANYTHING-EXCEPT-NUMBER TEST-TRUE-NEXT-MONKEY))

;; 6. line
(define-peg-pattern TEST-FALSE-NEXT-MONKEY all NUMBER)
(define-peg-pattern TEST-FALSE-LINE all (and ANYTHING-EXCEPT-NUMBER TEST-FALSE-NEXT-MONKEY))

(define-peg-pattern MONKEY all
  (and ID-LINE NEWLINE
       ITEMS-LINE NEWLINE
       OP-LINE NEWLINE
       TEST-LINE NEWLINE
       TEST-TRUE-LINE NEWLINE
       TEST-FALSE-LINE))

;; define model

(define-immutable-record-type <monkey>
  (make-monkey id items inspections operation test-divisor true-next false-next)
  monkey?
  (id monkey-id)
  (operation monkey-operation)
  (test-divisor monkey-test-divisor)
  (true-next monkey-true-next)
  (false-next monkey-false-next)
  (items monkey-items set-monkey-items)
  (inspections monkey-inspections set-monkey-inspections))


(set-record-type-printer!
 <monkey>
 (lambda (record port)
   (simple-format port
                  "<monkey: id:~a items:~a inspections:~a true-next:~a false-next:~a>"
                  (monkey-id record)
                  (monkey-items record)
                  (monkey-inspections record)
                  (monkey-true-next record)
                  (monkey-false-next record))))


(define-syntax ->
  (syntax-rules ()
    ;; first expression is left unchanged
    [(-> expr) expr]
    ;; take from the back, wrap other calls
    [(-> expr* ... (op args* ...))
     (op args* ... (-> expr* ...))]
    ;; make parens unnecessary in trivial case of no further arguments
    [(-> expr* ... op)
     (op (-> expr* ...))]))


(define lines (get-lines-from-file "input"))


(define monkey-lines
  (split-into-segments lines (λ (line) (string-null? line))))


(define string-operator->operator
  (λ (str)
    (cond
     [(string=? str "+") +]
     [(string=? str "*") *]
     [else (error "unrecognized operator" str)])))


(define monkey-lines->monkey
  (λ (lines)
    (let* ([monkey-str (string-join lines "\n")]
           [tree (peg:tree (match-pattern MONKEY monkey-str))])
      (let ([id (string->number (car (peg-tree:tree-refs tree '(ID))))]
            [items
             (map string->number
                  (string-split (car (peg-tree:tree-refs tree '(ITEMS-LINE NUMBER-LIST)))
                                #\,))]
            [inspections 0]
            ;; Operation is a function taking the previous
            ;; worry value as argument.
            [operation
             (let ([operand-str (car (peg-tree:tree-refs tree '(OPERATION OPERAND)))]
                   [operator
                    (string-operator->operator
                     (car (peg-tree:tree-refs tree '(OPERATION OPERATOR))))])
               ;; Handling the annoying special case ...
               (cond
                [(string=? operand-str "old")
                 (λ (worry)
                   (operator worry worry))]
                [else
                 (λ (worry)
                   (operator worry (string->number operand-str)))]))]
            [test-divisor
             (string->number
              (car (peg-tree:tree-refs tree '(TEST-DIVISOR))))]
            [test-true-next-monkey
             (string->number
              (car (peg-tree:tree-refs tree '(TEST-TRUE-NEXT-MONKEY))))]
            [test-false-next-monkey
             (string->number
              (car (peg-tree:tree-refs tree '(TEST-FALSE-NEXT-MONKEY))))])
        ;; (make-monkey id items inspections operation test true-next false-next)
        (make-monkey id
                     items
                     0  ; inspections so far
                     operation
                     test-divisor
                     test-true-next-monkey
                     test-false-next-monkey)))))


(define monkeys
  (list->vector
   (map monkey-lines->monkey
        monkey-lines)))


(define bored
  (λ (modulus item-worry)
    (remainder item-worry modulus)))


(define calc-modulus
  (λ (monkeys)
    (product
     (vector->list
      (vector-map (λ (index monkey) (monkey-test-divisor monkey))
                  monkeys)))))


(define move-items
  (λ (monkeys ind modulus)
    (let iter ([items° (monkey-items (vector-ref monkeys ind))]
               [monkeys° monkeys])
      (let* ([monkey (vector-ref monkeys ind)]
             [monkey-op (monkey-operation monkey)])
        (cond
         [(null? items°) monkeys°]
         [else
          (let* ([new-item-worry (-> items° car monkey-op (bored modulus))])
            (let ([target-monkey-ind
                   (if (divisible-by? new-item-worry (monkey-test-divisor monkey))
                       (monkey-true-next monkey)
                       (monkey-false-next monkey))])
              ;; (simple-format (current-output-port)
              ;;                "moving item from index: ~a to index: ~a\n"
              ;;                ind target-monkey-ind)

              ;; Remove item from current monkey's item list
              ;; and add to inspection counter.
              (vector-set! monkeys°
                           ind
                           (set-fields monkey
                                       ((monkey-inspections)
                                        (+ (monkey-inspections (vector-ref monkeys° ind)) 1))
                                       ((monkey-items) (drop items° 1))))
              ;; Append the item to the target monkey's item
              ;; list.
              (let* ([target-monkey (vector-ref monkeys° target-monkey-ind)]
                     [target-monkey-items
                      (append (monkey-items target-monkey)
                              (list new-item-worry))]
                     [updated
                      (set-monkey-items target-monkey target-monkey-items)])
                (vector-set! monkeys° target-monkey-ind updated))
              (iter (cdr items°) monkeys°)))])))))


(define calc-rounds
  (λ (monkeys num-rounds)
    ;; The mathematical trick to keep the integers low is to
    ;; calculate modulo. But what should the modulus be?
    ;; Each one of the monkeys' divisors alone would not
    ;; work. To calculate modulo one of them would change
    ;; the results with regards to another monkey's divisor,
    ;; when checking for divisibility. However, apparently
    ;; one can multiply all the divisors to get a bigger
    ;; modulus, which makes things work out for all monkeys'
    ;; divisibility tests.
    (define modulus (calc-modulus monkeys))
    (let iter ([round° 0] [monkeys° monkeys] [monkey-ind 0])
      (when (and (or (< round° 10) (= (remainder round° 100) 0)) (= monkey-ind 0))
        (simple-format (current-output-port) "state:\n")
        (pretty-print monkeys°))
      (cond
       [(>= round° num-rounds)
        ;; (simple-format (current-output-port) "done simulating rounds\n")
        monkeys°]
       [(>= monkey-ind (vector-length monkeys°))
        ;; (when (or (< round° 10)
        ;;           (= (remainder round° 100) 0))
        ;;   (simple-format (current-output-port) "simulate round ~a\n" round°))
        (iter (+ round° 1) monkeys° 0)]
       [else
        ;; (when (or (< round° 10)
        ;;           (= (remainder round° 1000) 0))
        ;;   (simple-format (current-output-port) "moving items of monkey ~a\n" monkey-ind))
        (iter round°
              (move-items monkeys° monkey-ind modulus)
              (+ monkey-ind 1))]))))


(define monkey-business
  (λ (monkeys)
    (product
     (n-highest
      (vector->list
       (vector-map (λ (ind monkey) (monkey-inspections monkey))
                   monkeys))
      2))))


(define after-10000-rounds (calc-rounds monkeys 10000))
;; (simple-format (current-output-port) "monkeys after 10000 rounds:\n")
;; (pretty-print after-10000-rounds)
(define result (monkey-business after-10000-rounds))
;; (simple-format (current-output-port)
;;                "~a\n"
;;                (vector->list
;;                 (vector-map (λ (ind monkey) (monkey-inspections monkey))
;;                             monkeys)))
(simple-format (current-output-port) "result: ~a\n" result)


;; (define apply-n-times
;;   (λ (func thing n)
;;     (let iter ([count 0] [result thing])
;;       (cond
;;        [(< count n)
;;         (iter (+ count 1) (func result))]
;;        [else
;;         result]))))