#! /usr/bin/env guile -e main -s
!#

;; TODO: make this a module

(use-modules (srfi srfi-1)
             (srfi srfi-9 gnu)
             (srfi srfi-11)
             (srfi srfi-43)
             (ice-9 control)
             (rnrs io ports)
             (ice-9 arrays))

(define (insert-sorted! x xs <)
  (merge! (list x) xs <))

(define (make-pq . elems) (map (lambda (x) (cons x 0)) elems))
(define pq-empty? null?)
(define (pq< a b) (< (cdr a) (cdr b)))
(define (pq-insert! pq x prio) (insert-sorted! (cons x prio) pq pq<))
(define (pq-pop pq) (values (cdr pq) (car pq)))

(define (ucs start succ win?)
  (define frontier (make-pq start))
  (define visited (make-hash-table))
  (hash-set! visited start (cons #f 0))

  (define (push! x cost)
    (set! frontier (pq-insert! frontier x cost)))

  (define (pop!)
    (let-values ([(pq node) (pq-pop frontier)])
      (set! frontier pq)
      (values (car node) (cdr node))))

  (let/ec return
    (while (not (pq-empty? frontier))
      (let-values ([(node cost) (pop!)])
        (when (win? node)
          (return cost node))

        (for-each
         (lambda (neighbor)
           (define total-cost (1+ cost))
           (when (or
                  (not (hash-ref visited neighbor))
                  (< total-cost (cdr (hash-ref visited neighbor))))
               (hash-set! visited neighbor (cons node total-cost))
               (push! neighbor total-cost)))
         (succ node))))
    (values #f #f)))

;; use set-field[s] instead of a setter fun
(define-immutable-record-type <square>
  (make-square box? goal? wall?)
  square?
  (box?  square-box?)
  (goal? square-goal?)
  (wall? square-wall?))

(define (square-solid? s) (or (square-box? s) (square-wall? s)))
(define (square-passable? s) (not (square-solid? s)))

;; there are actually only seven valid squares.
;; what the heck, let's save *some* allocations
;; used for . and + (player on goal)
(define square-goal  (make-square #f #t #f))
(define square-box   (make-square #t #f #f))
(define square-done  (make-square #t #t #f))
(define square-wall  (make-square #f #f #t))
(define square-empty (make-square #f #f #f))

(define (char->square+player? c)
  (case c
    [(#\.) (values square-goal  #f)]
    [(#\@) (values square-empty #t)]
    [(#\+) (values square-goal  #t)]
    [(#\$) (values square-box   #f)]
    [(#\*) (values square-done  #f)]
    [(#\#) (values square-wall  #f)]
    [else  (values square-empty #f)]))

(define (square+player?->char s player?)
  (define box?  (square-box? s))
  (define goal? (square-goal? s))
  (define wall? (square-wall? s))

  (cond
   [(and goal? player?) #\+]
   [(and goal? box?)    #\*]
   [player?             #\@]
   [goal?               #\.]
   [box?                #\$]
   [wall?               #\#]
   [else #\space]))


;; SWEET: we can use (make-typed-array 'b _ _) for a 2d bitarray (PLEASE be efficient)
;; what's really great about this is that there is way more sharing
;; goals and walls stay constant, so that saves even more time and memory
(define-immutable-record-type <board>
  (make-board player-x player-y boxes goals walls)
  board?
  (player-x board-player-x)
  (player-y board-player-y)
  (boxes board-boxes)
  (goals board-goals)
  (walls board-walls))

;; board = (player-pos (wall goal box)-bitsets)
(define (string->board s)
  ;; string-trim alone doesn't work because e.g.
  ;;   ###
  ;; ###.#
  ;; #@ $#
  ;; #   #
  ;; #####
  ;; becomes
  ;; ###
  ;; ###.#
  ;; #@ $#
  ;; #   #
  ;; #####
  ;; which is just no good

  (define lines (list->vector
                 (string-split (string-trim-both s (lambda (c) (eqv? c #\newline)))
                               #\newline)))
  (define widths (vector-map (lambda (_ line) (string-length line)) lines))
  (define width (apply max (vector->list widths)))
  (define height (vector-length lines))

  (define player-x #f)
  (define player-y #f)

  (define boxes (make-typed-array 'b #f width height))
  (define goals (make-typed-array 'b #f width height))
  (define walls (make-typed-array 'b #f width height))

  (vector-for-each
   (lambda (y line)
     (string-for-each-index
      (lambda (x)
        (define char (string-ref line x))
        (define-values (square player?) (char->square+player? char))
        (when player?
          (when player-x
            (error "more than one player"))
          (set! player-x x)
          (set! player-y y))
        (when (square-box?  square) (array-set! boxes #t x y))
        (when (square-goal? square) (array-set! goals #t x y))
        (when (square-wall? square) (array-set! walls #t x y)))
      line))
   lines)

  (unless (and player-x player-y)
    (error "no player found"))

  (make-board player-x player-y boxes goals walls))

(define (board-width b) (first (array-dimensions (board-boxes b))))
(define (board-height b) (second (array-dimensions (board-boxes b))))

;; TODO: maybe use existing squares
(define (board-ref b x y)
  (if (array-in-bounds? (board-boxes b) x y)
      (let ([box?  (array-ref (board-boxes b) x y)]
            [goal? (array-ref (board-goals b) x y)]
            [wall? (array-ref (board-walls b) x y)])
        (make-square box? goal? wall?))
      square-wall))

(define (board-for-each f b)
  (define width (board-width b))
  (define height (board-height b))
  (do ([x 0 (modulo (1+ x) width)]
       [y 0 (if (= (1+ x) width) (1+ y) y)])
      [(= y height)]
    (f (board-ref b x y) x y)))

(set-record-type-printer! <board>
 (lambda (b p)
   (format p "#<<board> (~a, ~a)\n  " (board-player-x b) (board-player-y b))
   (board-for-each
    (lambda (s x y)
      (put-char p (square+player?->char s (and (= x (board-player-x b))
                                               (= y (board-player-y b)))))
      (when (= (1+ x) (board-width b))
        (newline p)
        (unless (= (1+ y) (board-height b))
          (display "  " p))))
    b)
   (format p ">")))

;; functional version of array-set!
;; copies, of course
(define (board-move-box b x0 y0 x y)
  (define new-boxes (array-copy (board-boxes b)))
  (array-set! new-boxes #f x0 y0)
  (array-set! new-boxes #t x y)
  (set-field b (board-boxes) new-boxes))

;; EASY MONEY
(define (board-move-player b x y)
  (set-fields b [(board-player-x) x] [(board-player-y) y]))

(define (board-won? b)
  (when (zero? (random 10000))
    (format #t "~a\n" b))
  (let/ec return
    (board-for-each
     (lambda (c x y)
       (when (and (square-goal? c) (not (square-box? c)))
         (return #f)))
     b)
    #t))

(define (board-player-pos b)
  (values (board-player-x b) (board-player-y b)))

;; returns the *exact same board* when move is blocked
(define (board-step b dx dy)
  (define-values (x0 y0) (board-player-pos b))
  (define-values (x1 y1) (values (+ x0 dx) (+ y0 dy)))
  (define-values (x2 y2) (values (+ x1 dx) (+ y1 dy)))

  (define s0 (board-ref b x0 y0))
  (define s1 (board-ref b x1 y1))
  (define s2 (board-ref b x2 y2))

  (cond
   [(square-passable? s1) (board-move-player b x1 y1)]
   [(and (square-box? s1) (square-passable? s2))
    (board-move-player (board-move-box b x1 y1 x2 y2) x1 y1)]
   [else b]))

(define (board-succ b)
  (remove
   (lambda (newb) (eq? newb b))
   (map
    (lambda (dx dy) (board-step b dx dy))
    '( 0 0 -1 1)
    '(-1 1  0 0))))

(define (min-steps b)
  (ucs b board-succ board-won?))

;; by David Buchweitz
(define steaming-hot
  (string->board "
  #      #
 #   #  #
  # #  #
   # #  #
  #   #  #
 #   #  #
  # #  #

##########
#........####
# $$$$$$$#  #
#.$......#  #
# $$$$$$ #  #
#......$+#  #
#$$$$$$$ #  #
#        ####
##########
"))


(define microban-1
  (string->board "
####
# .#
#  ###
#*@  #
#  $ #
#  ###
####
"))

(define microban-2
  (string->board "
######
#    #
# #@ #
# $* #
# .* #
#    #
######
"))


(define (main args)
  (define-values (cost node) (min-steps (string->board (get-string-all (current-input-port)))))
  (format #t "~a\n~a\n" cost node))