;;;
;;; ICFPC 2012 Simulator
;;;

(define $RobotState
  (type
    {[,$val []
      {[$tgt (if (eq? tgt val)
                 {[]}
                 {})]}]
     [<normal> []
      {[<normal> {[]}]
       [_ {}]}]
     [<on-lambda> []
      {[<on-lambda> {[]}]
       [_ {}]}]
     [<abort> []
      {[<abort> {[]}]
       [_ {}]}]
     [<broken> []
      {[<broken> {[]}]
       [_ {}]}]
     [<goal> []
      {[<goal> {[]}]
       [_ {}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

(define $Tile
  (type
    {[<robot ,$pState> []
      {[<robot $state> (if ((= RobotState) pState state)
                           {[]}
                           {})]
       [_ {}]}]
     [<robot _> [RobotState]
      {[<robot $state> {state}]
       [_ {}]}]
     [<rock ,$pFlag> []
      {[<rock $flag> (if (eq? pFlag flag)
                         {[]}
                         {})]
       [_ {}]}]
     [<rock _> [Bool]
      {[<rock $flag> {[flag]}]
       [_ {}]}]
     [<wall> []
      {[<wall> {[]}]
       [_ {}]}]
     [<lambda-stone> []
      {[<lambda-stone> {[]}]
       [_ {}]}]
     [<earth> []
      {[<earth> {[]}]
       [_ {}]}]
     [<empty> []
      {[<empty> {[]}]
       [_ {}]}]
     [<open-lift> []
      {[<open-lift> {[]}]
       [_ {}]}]
     [<closed-lift> []
      {[<closed-lift> {[]}]
           [_ {}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

(define $show-tile
  (lambda [$tile]
    (match tile Tile
      {[<robot _> "R"]
       [<rock _> "*"]
       [<wall> "#"]
       [<lambda-stone> "\\"]
       [<earth> "."]
       [<empty> " "]
       [<open-lift> "O"]
       [<closed-lift> "L"]})))

(define $char-to-tile
  (lambda [$c]
    (match c Char
      {[,'R' <robot <normal>>]
       [,'*' <rock #f>]
       [,'#' <wall>]
       [,'\\' <lambda-stone>]
       [,'.' <earth>]
       [,' ' <empty>]
       [,'O' <open-lift>]
       [,'L' <closed-lift>]
       })))

(define $Mine (Array Tile))

(define $Move
  (type
    {[<left> []
      {[<left> {[]}]
       [_ {}]}]
     [<right> []
      {[<right> {[]}]
       [_ {}]}]
     [<up> []
      {[<up> {[]}]
       [_ {}]}]
     [<down> []
      {[<down> {[]}]
       [_ {}]}]
     [<wait> []
      {[<wait> {[]}]
       [_ {}]}]
     [<abort> []
      {[<abort> {[]}]
           [_ {}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

(define $char-to-move
  (lambda [$c]
    (match c Char
      {[,'L' <left>]
       [,'R' <right>]
       [,'U' <up>]
       [,'D' <down>]
       [,'W' <wait>]
       [,'A' <abort>]
       [,'h' <left>]
       [,'l' <right>]
       [,'k' <up>]
       [,'j' <down>]
       })))

(define $Point [Integer Integer])

(define $GameState
  (type
    {[<game-state _ _ _ _> [Mine Integer Integer Integer]
      {[<game-state $mine $step $score $lambda-count>
        {[mine step score lambda-count]}]}]
     [_ [Something]
      {[$tgt {tgt}]}]
     }))

(define $get-mine
  (lambda [$game-state]
    (match game-state GameState
      {[<game-state $mine _ _ _> mine]})))

(define $show-mine
  (lambda [$mine]
    (let {[$kss (keys-for-display (array-range mine))]}
      (foldl string-append ""
             (map (lambda [$ks]
                    (string-append (foldl string-append ""
                                          (map (lambda [$k]
                                                 (show-tile (array-ref k mine))) ks))
                                   "\n"))
                  kss)))))

(define $get-robot-state
  (lambda [$mine]
    (let {[$rp ((find-from-value-with-pattern Tile) <robot _> mine)]}
      (match (array-ref rp mine) Tile
        {[<robot $state> state]}))))

(define $move-robot
  (lambda [$mine $move]
    (generate-array
      (lambda [$x $y]
        (match move Move
          {[<left>
            (match mine Mine
              {
               [(& <cons ,[x y] <robot _>>
                   <cons ,[(- x 1) y] <open-lift>>)
                <empty>]
               [(& <cons ,[x y] <open-lift>>
                   <cons ,[(+ x 1) y] <robot _>>)
                <robot <goal>>]
               [(& <cons ,[x y] <robot _>>
                   <cons ,[(- x 1) y] <lambda-stone>>)
                <empty>]
               [(& <cons ,[x y] <lambda-stone>>
                   <cons ,[(+ x 1) y] <robot _>>)
                <robot <on-lambda>>]
               [(& <cons ,[x y] <robot _>>
                   (| ^<cons ,[(- x 1) y] (| <wall> <rock _>)>
                      (& <cons ,[(- x 1) y] <rock _>>
                         <cons ,[(- x 2) y] <empty>>)))
                <empty>]
               [(& <cons ,[(+ x 1) y] <robot _>>
                   (| ^<cons ,[x y] (| <wall> <rock _>)>
                      (& <cons ,[x y] <rock _>>
                         <cons ,[(- x 1) y] <empty>>)))
                <robot <normal>>]
               [(& <cons ,[x y] <empty>>
                   <cons ,[(+ x 1) y] <rock _>>
                   <cons ,[(+ x 2) y] <robot _>>)
                <rock #f>]
               [<cons ,[x y] <robot _>>
                <robot <normal>>]
               [<cons ,[x y] $tile> tile]})]
           [<right>
            (match mine Mine
              {
               [(& <cons ,[x y] <robot _>>
                   <cons ,[(+ x 1) y] <open-lift>>)
                <empty>]
               [(& <cons ,[x y] <open-lift>>
                   <cons ,[(- x 1) y] <robot _>>)
                <robot <goal>>]
               [(& <cons ,[x y] <robot _>>
                   <cons ,[(+ x 1) y] <lambda-stone>>)
                <empty>]
               [(& <cons ,[x y] <lambda-stone>>
                   <cons ,[(- x 1) y] <robot _>>)
                <robot <on-lambda>>]
               [(& <cons ,[x y] <robot _>>
                   (| ^<cons ,[(+ x 1) y] (| <wall> <rock _>)>
                      (& <cons ,[(+ x 1) y] <rock _>>
                         <cons ,[(+ x 2) y] <empty>>)))
                <empty>]
               [(& <cons ,[(- x 1) y] <robot _>>
                   (| ^<cons ,[x y] (| <wall> <rock _>)>
                      (& <cons ,[x y] <rock _>>
                         <cons ,[(+ x 1) y] <empty>>)))
                <robot <normal>>]
               [(& <cons ,[x y] <empty>>
                   <cons ,[(- x 1) y] <rock _>>
                   <cons ,[(- x 2) y] <robot _>>)
                <rock #f>]
               [<cons ,[x y] <robot _>>
                <robot <normal>>]
               [<cons ,[x y] $tile> tile]})]
           [<up>
            (match mine Mine
              {
               [(& <cons ,[x y] <robot _>>
                   <cons ,[x (+ y 1)] <open-lift>>)
                <empty>]
               [(& <cons ,[x y] <open-lift>>
                   <cons ,[x (- y 1)] <robot _>>)
                <robot <goal>>]
               [(& <cons ,[x y] <robot _>>
                   <cons ,[x (+ y 1)] <lambda-stone>>)
                <empty>]
               [(& <cons ,[x y] <lambda-stone>>
                   <cons ,[x (- y 1)] <robot _>>)
                <robot <on-lambda>>]
               [(& <cons ,[x y] <robot _>>
                   ^<cons ,[x (+ y 1)] (| <wall> <rock _>)>)
                <empty>]
               [(& <cons ,[x (- y 1)] <robot _>>
                   ^<cons ,[x y] (| <wall> <rock _>)>)
                <robot <normal>>]
               [<cons ,[x y] <robot _>>
                <robot <normal>>]
               [<cons ,[x y] $tile> tile]})]
           [<down>
            (match mine Mine
              {
               [(& <cons ,[x y] <robot _>>
                   <cons ,[x (- y 1)] <open-lift>>)
                <empty>]
               [(& <cons ,[x y] <open-lift>>
                   <cons ,[x (+ y 1)] <robot _>>)
                <robot <goal>>]
               [(& <cons ,[x y] <robot _>>
                   <cons ,[x (- y 1)] <lambda-stone>>)
                <empty>]
               [(& <cons ,[x y] <lambda-stone>>
                   <cons ,[x (+ y 1)] <robot _>>)
                <robot <on-lambda>>]
               [(& <cons ,[x y] <robot _>>
                   ^<cons ,[x (- y 1)] (| <wall> <rock _>)>)
                <empty>]
               [(& <cons ,[x (+ y 1)] <robot _>>
                   ^<cons ,[x y] (| <wall> <rock _>)>)
                <robot <normal>>]
               [<cons ,[x y] <robot _>>
                <robot <normal>>]
               [<cons ,[x y] $tile> tile]})]
           [<abort>
            (match mine Mine
              {[<cons ,[x y] <robot _>>
                <robot <abort>>]
               [<cons ,[x y] $tile> tile]})]
           [<wait>
            (match mine Mine
              {[<cons ,[x y] <robot _>>
                <robot <normal>>]
               [<cons ,[x y] $tile> tile]})]
           }))
      (array-range mine))))
                           
(define $update-map
  (lambda [$mine]
    (generate-array
      (lambda [$x $y]
        (match mine Mine
          {[(& <cons ,[x y] <empty>>
               <cons ,[x (+ y 1)] <rock _>>)
            <rock #t>]
           [(& <cons ,[x (- y 1)] <empty>>
               <cons ,[x y] <rock _>>)
            <empty>]
           [(& <cons ,[x y] <empty>>
               <cons ,[(- x 1) y] (| <rock _> <lambda-stone>)>
               <cons ,[(- x 1) (+ y 1)] <rock _>>
               <cons ,[x (+ y 1)] <empty>>)
            <rock #t>]
           [(& <cons ,[x y] <rock _>>
               <cons ,[x (- y 1)] (| <rock _> <lambda-stone>)>
               <cons ,[(+ x 1) (- y 1)] <empty>>
               <cons ,[(+ x 1) y] <empty>>)
            <empty>]
           [(& <cons ,[x y] <rock _>>
               <cons ,[x (- y 1)] <rock _>>
               (| <cons ,[(+ x 1) y] ^<empty>>
                  <cons ,[(+ x 1) (- y 1)] ^<empty>>)
               <cons ,[(- x 1) (- y 1)] <empty>>
               <cons ,[(- x 1) y] <empty>>)
            <empty>]
           [(& <cons ,[(+ x 1) (+ y 1)] <rock _>>
               <cons ,[(+ x 1) y] <rock _>>
               (| <cons ,[(+ x 2) y] ^<empty>>
                  <cons ,[(+ x 2) (+ y 1)] ^<empty>>)
               <cons ,[x (+ y 1)] <empty>>
               <cons ,[x y] <empty>>)
            <rock #t>]
           [<cons ,[x y] <closed-lift>>
            (if (eq? 0 (size (lambda-stones mine)))
                <open-lift>
                <closed-lift>)]
           [<cons ,[x y] <rock _>>
                <rock #f>]
           [<cons ,[x y] $tile> tile]
           }))
      (array-range mine))))

(define $lambda-stones
  (lambda [$mine]
    (concat (map (lambda [$x $y]
                   (match mine Mine
                     {[<cons ,[x y] <lambda-stone>> {[x y]}]
                      [_ {}]}))
                 (array-keys mine)))))

(define $ending-update
  (lambda [$mine]
    (generate-array
      (lambda [$x $y]
        (match mine Mine
          {[(& <cons ,[x y] <robot _>>
               <cons ,[x (+ y 1)] <rock ,#t>>)
            <robot <broken>>]
           [<cons ,[x y] $tile> tile]
           }))
      (array-range mine))))

(define $ending?
  (lambda [$mine]
    (match (get-robot-state mine) RobotState
      {[(| <abort> <broken> <goal>) #t]
       [_ #f]})))

(define $calc-score
  (lambda [$game-state]
    (match game-state GameState
      {[<game-state $mine $step $score $lambda-count>
        (match (get-robot-state mine) RobotState
          {[<goal> (+ score (* 25 lambda-count))]
           [<abort> score]
           [<broken> 0]})]})))

(define $generate-mine
  (lambda [$lines]
    (do {[$tss (map (lambda [$line]
                      (map char-to-tile
                           (string-to-chars line)))
                    (reverse lines))]
         [$mx (max (map size tss))]
         [$my (size tss)]
         [$tss2 (map (lambda [$cs]
                       {@cs @(loop $l $i (between 1 (- mx (size cs))) {<wall> @l} {})})
                     tss)]
         }
      (letrec {[$rotate
                (lambda [$tss]
                  (match (car tss) (List Something)
                    {[<nil> {}]
                     [_ {(map car tss) @(rotate (map cdr tss))}]}))]}
        (let {[$tss3 (rotate tss2)]}
          (generate-array
            (lambda [$x $y] (nth y (nth x tss3)))
            [mx my]))))))

(define $main
  (lambda [$world $argv]
    (match argv (List String)
      {[<cons $file <nil>>
        (do {[[$world $port] (open-input-file world file)]
             }
          (letrec {[$readMapLoop (lambda [$world $lines]
                                   (do {[[$world $line] (read-line-from-port world port)]}
                                     (if (or (eof? line) (eq-s? line ""))
                                         [world lines]
                                         (readMapLoop world {@lines line}))))]
                   }
            (do {[[$world $lines] (readMapLoop world {})]
                 [$init-mine (generate-mine lines)]
                 [$init-state <game-state init-mine 0 0 0>]}
              (letrec {[$interactive
                        (lambda [$world $game-state]
                          (match game-state GameState
                            {[<game-state $mine $step $score $lambda-count>
                              (do {
                                   [$world (write-string world (show-mine mine))]
                                   [$world (write-char world '\n')]
                                   [$world (write-string world "robot-state: ")]
                                   [$world (write world (get-robot-state mine))]
                                   [$world (write-char world '\n')]
                                   [$world (write-string world "lambda-count: ")]
                                   [$world (write world lambda-count)]
                                   [$world (write-char world '\n')]
                                   [$world (write-string world "score: ")]
                                   [$world (write world score)]
                                   [$world (write-char world '\n')]
                                   [$world (write-string world "command: ")]
                                   [$world (flush world)]
                                   [[$world $cmd] (read-char world)]
                                   [$world (write-char world '\n')]
                                   [$world (flush world)]
                                   [$move (char-to-move cmd)]
                                   [$mine2 (ending-update (update-map (move-robot mine move)))]
                                   [$game-state2 <game-state mine2 (+ 1 step)
                                                             (if ((= RobotState) <on-lambda> (get-robot-state mine2))
                                                                 (- (+ 50 score) 1)
                                                                 (- score 1))
                                                             (if ((= RobotState) <on-lambda> (get-robot-state mine2))
                                                                 (+ 1 lambda-count)
                                                                 lambda-count)
                                                             >]
                                   }
                                (if (ending? mine2)
                                    (do {
                                         [$world (write-string world (show-mine mine2))]
                                         [$world (write-char world '\n')]
                                         [$world (write-string world "robot-state: ")]
                                         [$world (write world (get-robot-state mine2))]
                                         [$world (write-char world '\n')]
                                         [$world (write-string world "score: ")]
                                         [$world (write world (calc-score game-state2))]
                                         [$world (write-char world '\n')]
                                         }
                                      world)
                                    (interactive world game-state2)))]}))]}
                (interactive world init-state)))))]
       [_ (do {
               [$world (write-string world "usage: mine FILENAME (specify map file)\n")]
               }
            world)]})))