#!/usr/local/bin/chicken-csi -ss
(import (chicken io)
        (chicken string))

; utils
(define (range n)
  (if (equal? n 0)
      '(0)
      (append (range (sub1 n)) (list n))))

(define (filter pred lst)
  (if (null? lst)
      '()
      (if (pred (car lst))
          (cons (car lst) (filter pred (cdr lst)))
          (filter pred (cdr lst)))))

(define (first-n lst n)
  (if (equal? n 0)
     	'() 
			(cons (car lst) (first-n (cdr lst) (sub1 n)))))

(define (n-on lst n)
  (if (equal? n 0)
     	lst
			(n-on (cdr lst) (sub1 n))))

;        [D]
;    [N] [C]      =>  ((N Z) (D C M) (P))
;    [Z] [M] [P]
;     1   2   3

; key insight: chars are at 1 5 ... N - 2 (where n = length)
(define (get-mask n)
  (filter (lambda (x) (eq? (modulo x 4) 1))
          (range n)))

(define (get-boxes line)
  (map (lambda (k) (substring line k (add1 k)))
       (get-mask (string-length line))))

(define (add-layer boxes stacks)
  (cond ((null? boxes)
         '())
        ((equal? (car boxes) " ")
         (cons (car stacks) (add-layer (cdr boxes) (cdr stacks))))
        (else
         (cons (cons (car boxes) (car stacks))
               (add-layer (cdr boxes) (cdr stacks))))))

(define (init-stacks n)
  (map (lambda (x) '()) (get-mask n)))

(define (parse-boxes lines)
  (let ((n (string-length (car lines))))
    (let loop ((lines lines) (stacks (init-stacks n)))
      (let ((l (car lines)))
        (if (equal? l "")
            (map (lambda (s) (reverse (cdr s))) stacks)
            (loop (cdr lines) (add-layer (get-boxes l) stacks)))))))

; move N from A to B -> (N A B)
(define (parse-move x)
  (let* ((parts (string-split x))
         (count (string->number (list-ref parts 1)))
         (from  (sub1 (string->number (list-ref parts 3))))
         (to    (sub1 (string->number (list-ref parts 5)))))
    (list count from to)))

; TODO: this could be filter + map
(define (parse-moves lines)
    (cond ((null? lines) '())
          ((and (> (string-length (car lines)) 0)
                (equal? (substring (car lines) 0 1) "m"))
           (cons (parse-move (car lines)) (parse-moves (cdr lines))))
          (else (parse-moves (cdr lines)))))

(define (pop-box stacks k)
  (if (>= k (length stacks))
      (error "Bad pop")
      (if (equal? k 0)
          (values (caar stacks) (cons (cdar stacks) (cdr stacks)))
          (let-values (((b sts) (pop-box (cdr stacks) (sub1 k))))
            (values b (cons (car stacks) sts))))))

(define (push-box stacks k e)
  (if (>= k (length stacks))
      (error "Bad push")
      (if (equal? k 0)
          (cons (cons e (car stacks)) (cdr stacks))
          (cons (car stacks) (push-box (cdr stacks) (sub1 k) e)))))

(define (pop-boxes stacks k n)
  (if (>= k (length stacks))
      (error "Bad pop")
      (if (equal? k 0)
          (values (first-n (car stacks) n) (cons (n-on (car stacks) n) (cdr stacks)))
          (let-values (((b sts) (pop-boxes (cdr stacks) (sub1 k) n)))
            (values b (cons (car stacks) sts))))))

(define (push-boxes stacks k e)
  (if (>= k (length stacks))
      (error "Bad push")
      (if (equal? k 0)
          (cons (append e (car stacks)) (cdr stacks))
          (cons (car stacks) (push-boxes (cdr stacks) (sub1 k) e)))))

(define (play-move-1 move stacks)
  (let ((n (car move))
        (f (cadr move))
        (t (caddr move)))
		(let-values (((boxes sts) (pop-boxes stacks f n)))
			(push-boxes sts t (reverse boxes)))))

; same as 1, but no reverse
(define (play-move-2 move stacks)
  (let ((n (car move))
        (f (cadr move))
        (t (caddr move)))
		(let-values (((boxes sts) (pop-boxes stacks f n)))
			(push-boxes sts t boxes))))

(define (play-moves moves stacks player)
  (if (null? moves)
      stacks
      (play-moves (cdr moves) (player (car moves) stacks) player)))

; TODO: add1/sub1 on stack nums, iterate, profit
(define (main args)
  (let* ((lines  (read-lines))
         (stacks (parse-boxes lines))
         (moves  (parse-moves lines)))
    (for-each (lambda (s) (display (car s)))
              (play-moves moves stacks play-move-1))
    (newline)
    (for-each (lambda (s) (if (not (eq? 'tmp (car s))) (display (car s))))
              (play-moves moves (append stacks '((tmp))) play-move-2))
    (newline)))

; test data for the REPL
(define sks '((N Z) (D C M) (P)))

(main '())