William Tozier's Cargo-Bot error heuristic

099cargobot.wart

;; Draft solution of William Tozier's Cargo-Bot problem:
;;   http://www.vagueinnovation.com/pragmatic_gp/more-on-moving-blocks
;;
;; Built in a private lisp dialect I've been working on:
;;   http://github.com/akkartik/wart#readme
;; Requires gcc and linux/macos.
;;
;; Instructions to run tests:
;;   $ git clone http://github.com/akkartik/wart.git
;;   $ cd wart
;;   $ git checkout 6a36d5b5b7
;;   $ wget --no-check-certificate https://raw.github.com/gist/2731697/099cargobot.wart
;;   $ wart

= verbose 1

def log args
  if verbose
    prn @args
  last.args

def right-justify(n l)
  (join (collect:repeat (- n len.l)
          yield.nil)
        l)

def zipright(l r)
  if (> len.l len.r)
    (zip l (right-justify len.l r))
    (zip (right-justify len.r l) r)

def cleanup_error(target observed)
  sum:collect:on stack (map zipright target observed)
    let stack_index index
      on (t o) stack
        if (and t (~iso t o))
          yield (cleanup_error_sub target observed stack_index index)

; for every crate in target:
;   if observed:
;     has the correct crate in that position: 0
;     has the wrong color in that position:
;       min(number of crates needed to dig out the right colored crate from any stack IN OBSERVED)
;         +(number of crates needed to dig out the wrong crate FROM OBSERVED)
;     has no crate in that position:
;       min(number of crates needed to dig out the right colored crate from any stack IN OBSERVED)
;         +(number of crates needed (if any) to support the missing crate IN OBSERVED)
def cleanup_error_sub(target observed stack_index index)
  log "target: " target
  log "observed: " observed
  let val target.stack_index.index
    if (and observed.stack_index (iso val observed.stack_index.index))
      0
      (do
        log "considering " val " " index
        log "result "
          (+ (if (<= len:observed.stack_index index)
               (log "stack under "
                 (- index (- len:observed.stack_index 1)))
               (log "dig out "
                 (+ (- len:observed.stack_index index) 1)))
             log "to find the right block: "
               (min @(skip nil
                           (log "looking for " val " in " (map (fn(_)
                                  (aif (rpos val _)
                                    (- len._ it)))
                                observed))))))

(test "cleanup_error works for 1-high stacks"
 :valueof (cleanup_error '((r) ()) '((r) ()))
 :should be 0)

(test "cleanup_error works for 1-high stacks - 2"
 :valueof (cleanup_error '((r) ()) '(() (r)))
 :should be 2)

(test "cleanup_error works for 1-high stacks - 3"
 :valueof (cleanup_error '((r) (g)) '((g) (r)))
 :should be 6)

(test "cleanup_error handles inserting from the bottom of a stack"
 :valueof (cleanup_error '((r) (b b)) '(() (r b b)))
 :should be 4)

(test "cleanup_error_sub handles inserting under other crates"
 :valueof (cleanup_error_sub '((b r) (g g)) '((r) (g g b)) 0 0)
 :should be 3)

(test "cleanup_error_sub handles inserting under other crates - 3"
 :valueof (cleanup_error_sub '((b r r) (g g)) '((r r) (g g b)) 0 0)
 :should be 4)

(test "cleanup_error_sub handles inserting under other crates - 4"
 :valueof (cleanup_error_sub '((r b r r) (g g)) '((r r r) (g g b)) 0 1)
 :should be 4)

(test "cleanup_error_sub handles inserting under other crates - 2"
 :valueof (cleanup_error_sub '((g g b r) (g g)) '((g g r) (g g b)) 0 2)
 :should be 3)



;; William Tozier's tests translated from
;; http://github.com/Vaguery/CargoBot-ruby/blob/54902aeb90/features/cleanup_distance.feature
;;
;; Doesn't include tests for new penalty-100 rule.
;;
;; These don't work yet.
;; http://www.vagueinnovation.com/pragmatic_gp/more-on-moving-blocks/#comment-9

(test "1"
 :valueof (cleanup_error_sub '((r) ()) '((r) ()) 0 0)
 :should be 0)

(test "2"
 :valueof (cleanup_error_sub '((r) ()) '(() (r)) 0 0)
 :should be 2)

(test "3"
 :valueof (cleanup_error_sub '((r b) ()) '((r) (b)) 0 1)
 :should be 2)

(test "4"
 :valueof (cleanup_error_sub '((r) (b b)) '(() (r b b)) 0 0)
 :should be 4)

(test "5"
 :valueof (cleanup_error_sub '((r) (r b b) (g r g)) '(() (r r b b) (g r g)) 0 0)
 :should be 3)

(test "6"
 :valueof (cleanup_error_sub '((g r r r)) '((r r r g)) 0 0)
 :should be 5)

(test "7"
 :valueof (cleanup_error_sub '((g r r r) (b b) (g y y y)) '((b r r r) (g b) (g y y y)) 0 0)
 :should be 6)

(test "8"
 :valueof (cleanup_error_sub '((r r b) ()) '((r) (b r)) 0 2)
 :should be 4)

(test "9"
 :valueof (cleanup_error_sub '((y y y r) (b b)) '(() (y y y r b b)) 0 3)
 :should be 8)

(test "10 - double-count"
 :valueof (cleanup_error_sub '((r r r r b r)) '((b r r r r r)) 0 4)
 :should be 11)

(test "11"
 :valueof (cleanup_error_sub '((r r b r r)) '((b r r r r)) 0 2)
 :should be 8)

(test "12 - floating"
 :valueof (cleanup_error_sub '((r r b r r) ()) '((r) (r b r)) 0 3)
 :should be 6)

(test "13 - total cleanup_error"
 :valueof (cleanup_error '((r r r r b r)) '((b r r r r r)))
 :should be 18)

(test "14"
 :valueof (cleanup_error '(() (r r r r b r)) '((b r r r r r) ()))
 :should be 21)

(test "15"
 :valueof (cleanup_error_sub '((y y y r) (b b)) '(() (y y y r b b)) 0 0)
 :should be 5)

(test "16"
 :valueof (cleanup_error_sub '((y y y r) (b b)) '(() (y y y r b b)) 0 1)
 :should be 6)

(test "17"
 :valueof (cleanup_error_sub '((y y y r) (b b)) '(() (y y y r b b)) 0 2)
 :should be 7)

(test "18"
 :valueof (cleanup_error_sub '((y y y r) (b b)) '(() (y y y r b b)) 0 3)
 :should be 8)

(test "19"
 :valueof (cleanup_error '((y y y r) (b b)) '(() (y y y r b b)))
 :should be 49)

(test "20 - 19 reversed"
 :valueof (cleanup_error '(() (y y y r b b)) '((y y y r) (b b)))
 :should be 37)

quit.