advent-of-code-2022/day-05/part-01.scm

(import
 (except (rnrs base) let-values map)
 (only (guile)
       lambda* λ
       string-split
       string->number
       string-join)
 (fileio)
 (srfi srfi-1)
 (srfi srfi-8)
 (srfi srfi-11)
 (ice-9 pretty-print)
 (ice-9 match))


(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-syntax define-mapped
  (syntax-rules ()
    [(_ name body-expr)
     (define name
       (λ (arg)
         (map (λ (one)
                (body-expr one))
              arg)))]))


(define split-list
  (λ (lst pred)
    (let iter ([lst° lst]
               [cont (λ (acc-split-off remaining)
                       (values acc-split-off remaining))])
      (cond
       [(null? lst°)
        (cont '() '())]
       [(pred (car lst°))
        (cont '() (cdr lst°))]
       [else
        (iter (cdr lst°)
              (λ (split-off remaining)
                (cont (cons (car lst°) split-off)
                      remaining)))]))))


(define split-stack-config-string
  (λ (str)
    ;; |0123456789
    ;; |[T] [L] [D] [G] [P] [P] [V] [N] [R]
    (let ([positions '(1 5 9 13 17 21 25 29 33)])
      (map (λ (pos) (substring str pos (+ pos 1)))
           positions))))


(define transpose
  (λ (mat)
    (let iter ([mat° mat] [transposed '()])
      (cond
       [(null? (car mat°)) transposed]
       [else
        (iter (map (λ (row) (cdr row)) mat°)
              (cons (map (λ (row) (car row)) mat°) transposed))]))))


;; MOVE abstraction

(define execute-move
  (λ (move stacks)
    (let ([from (move-from move)]
          [to (move-to move)])
      (let iter ([stack-index 1]
                 [stacks° stacks])
        (cond
         [(null? stacks°) '()]
         [(= stack-index from)
          (cons (cdr (list-ref stacks (- from 1)))
                (iter (+ stack-index 1)
                      (drop stacks° 1)))]
         [(= stack-index to)
          (cons (cons (car (list-ref stacks (- from 1)))
                      (list-ref stacks (- to 1)))
                (iter (+ stack-index 1)
                      (drop stacks° 1)))]
         [else
          (cons (car stacks°)
                (iter (+ stack-index 1)
                      (cdr stacks°)))])))))

(define make-move
  (λ (from to)
    (cons from to)))

(define move-from
  (λ (move)
    (car move)))

(define move-to
  (λ (move)
    (cdr move)))

(define run-moves
  (λ (move-str stacks)
    (display (simple-format #f "running move: ~a\n" move-str))
    (match (string-split move-str #\space)
      [(_1 amount-str _2 from-str _3 to-str)
       (let ([amount (string->number amount-str)]
             [from (string->number from-str)]
             [to (string->number to-str)])
         (let iter ([counter 0] [stacks° stacks])
           (cond
            [(< counter amount)
             (iter (+ counter 1)
                   (execute-move (make-move from to)
                                 stacks°))]
            [else stacks°])))]
      [_ (error "unrecognized move")])))

(define lines (get-lines-from-file "input"))
(define-values (stacks-config moves) (split-list lines string-null?))
(define initial-stacks
  (reverse
   (map (λ (stack)
          (filter (λ (elem)
                    (and (not (string=? " " elem))
                         (not (string->number elem))))
                  stack))
        (transpose
         (map split-stack-config-string stacks-config)))))

(pretty-print initial-stacks)
(define final-stacks
  (let iter ([moves° moves] [stacks° initial-stacks])
    (cond
     [(null? moves°) stacks°]
     [else
      (iter (cdr moves°)
            (run-moves (car moves°)
                       stacks°))])))


(pretty-print final-stacks)
(pretty-print (string-join (map (λ (stack) (car stack)) final-stacks) ""))