(module pentominoes mzscheme

  (require (lib "etc.ss")
           (lib "match.ss"))

  
  
  (define boxwidth 40)
  (define boxheight 40)
  

  (define-struct shape (char configs color))
  
  
  
  ;; a board is a vector of vectors, n rows with m columns
  (define m 10)
  (define n 10)
  
  (define (rect-ref rect x y)
    (vector-ref (vector-ref rect y) x))
  (define (rect-set! rect x y val)
    (vector-set! (vector-ref rect y) x val))
  
  (define board (build-vector 10 (lambda (dc) (make-vector 10 #f))))
  (define (board-ref x y) (rect-ref board x y))
  (define (board-set! x y val) (rect-set! board x y val))
  
  (define (rect-loop xlimit ylimit body)
    (let ([ylimitval ylimit]
          [xlimitval xlimit])
      (let row-loop ([yvar 0])
        (unless (>= yvar ylimitval)
          (let col-loop ([xvar 0])
            (unless (>= xvar xlimitval)
              (body xvar yvar)
              (col-loop (+ xvar 1))))
          (row-loop (+ yvar 1))))))
  
  
  (define (map->box vecvec)
    (vector (vector-length (vector-ref vecvec 0))
            (vector-length vecvec)))
  
  (define (rot map)
    (let ([box (map->box map)])
      (let ([newmap (build-vector (vector-ref box 0)
                                  (lambda (i)
                                    (make-vector (vector-ref box 1) #f)))])
        (rect-loop (vector-ref box 0) (vector-ref box 1)
                   (lambda (x y)
                     (when (rect-ref map x y)
                       (rect-set! newmap y (- (vector-ref box 0) x 1) #t))))
        newmap)))
  
  (define (flip map)
    (let ([box (map->box map)])
      (let ([newmap (build-vector (vector-ref box 1)
                                  (lambda (i)
                                    (make-vector (vector-ref box 0) #f)))])
        (rect-loop (vector-ref box 0)
                    (vector-ref box 1)
                    (lambda (x y)
                      (when (rect-ref map x y)
                        (rect-set! newmap (- (vector-ref box 0) x 1) y #t))))
        newmap)))
  
  (define (all-ways shape)
    (let ([rots (all-rots shape)])
      (append rots (map flip rots))))
  
  (define (all-rots shape)
    (build-list 4 (lambda (n) (n-power n rot shape))))
  
  (define (n-power n fn base)
    (if (= n 0)
        base 
        (fn (n-power (- n 1) fn base))))
  
  (define f-1 #(#(#f #t #t)
                #(#t #t #f)
                #(#f #t #f)))
  (define all-fs (make-shape #\f (all-ways f-1) "NavajoWhite"))
  
  (define ell-1 #(#(#t #f)
                  #(#t #f)
                  #(#t #f)
                  #(#t #t)))
  (define all-ells (make-shape #\l (all-ways ell-1) "Peru"))
  
  (define bar-1 #(#(#t) #(#t) #(#t) #(#t) #(#t)))
  (define all-bars (make-shape #\i (list bar-1 (rot bar-1)) "Chartreuse"))
  
  (define t-1 #(#(#t #t #t)
                #(#f #t #f)
                #(#f #t #f)))
  (define all-ts (make-shape #\t (all-rots t-1) "Medium Spring Green"))
  
  (define cross-1 #(#(#f #t #f)
                    #(#t #t #t)
                    #(#f #t #f)))
  (define all-crosses (make-shape #\x (list cross-1) "Silver"))
  
  (define lump-1 #(#(#t #f)
                   #(#t #t)
                   #(#t #t)))
  (define all-lumps (make-shape #\p (all-ways lump-1) "Teal"))
  
  (define zee-1 #(#(#t #t #f)
                  #(#f #t #f)
                  #(#f #t #t)))
  (define all-zees (make-shape #\z (all-rots zee-1) "OliveDrab"))
  
  (define zig-1 #(#(#t #f)
                  #(#t #t)
                  #(#f #t)
                  #(#f #t)))
  (define all-zigs (make-shape #\n (all-ways zig-1) "Orange"))
  
  (define jab-1 #(#(#t #f)
                  #(#t #t)
                  #(#t #f)
                  #(#t #f)))
  (define all-jabs (make-shape #\y (all-ways jab-1) "Burlywood"))
  
  (define square-ell-1 #(#(#t #f #f)
                         #(#t #f #f)
                         #(#t #t #t)))
  (define all-square-ells (make-shape #\v (all-rots square-ell-1) "SandyBrown"))
  
  (define u-1 #(#(#t #f #t)
                #(#t #t #t)))
  (define all-us (make-shape #\u (all-rots u-1) "Orchid"))
  
  (define w-1 #(#(#t #f #f)
                #(#t #t #f)
                #(#f #t #t)))
  (define all-ws (make-shape #\w (all-rots w-1) "HotPink"))
  
  (define pieces (list all-ells all-bars all-jabs all-zigs
                       all-fs all-ws all-us
                       all-crosses
                       all-zees
                       all-square-ells all-ts all-lumps ))
  
  
  (define (find-a-place pbm char success)
    (let/ec escape
      (let ([prect (map->box pbm)])
        (rect-loop (+ 1 (- m (vector-ref prect 0)))
                    (+ 1 (- n (vector-ref prect 1)))
                    (lambda (x y)
                      (when (can-place? pbm prect x y)
                        (success (vector x y))))))))
  
  (define (place pbm prect vec color)
    (place/unplace pbm prect (vector-ref vec 0) (vector-ref vec 1) color))
  
  (define (unplace pbm prect vec)
    (place/unplace pbm prect (vector-ref vec 0) (vector-ref vec 1) #f))
  
  (define (place/unplace pbm prect x y place?)
    (rect-loop (vector-ref prect 0)
                (vector-ref prect 1)
                (lambda (dx dy)
               (when (rect-ref pbm dx dy)
                 (board-set! (+ x dx) (+ y dy) place?)))))
  
  (define (can-place? pbm prect x y)
    (let/ec k
      (rect-loop (vector-ref prect 0)
                 (vector-ref prect 1)
                 (lambda (dx dy)
                   (when (and (rect-ref pbm dx dy) (board-ref (+ x dx) (+ y dy)))
                     (k #f))))
      #t))
  
  
  (define (maybe test then else)
    (if test (then test) (else)))
  
  (define pending-char #f)
  
  (define constraints 
    `((0 3 1) 
      (1 5 6)
      (3 0 1)
      (3 5 5)
      (4 2 3)
      (4 3 6)
      (4 8 4)
      (5 4 6)
      (5 8 2)
      (6 1 4)
      (7 3 4)
      (8 5 2)
      (9 8 3)))
  
  (for-each (lambda (xy)
              (board-set! (car xy) (cadr xy) "White"))
            constraints)
  
  (define (test-constraints/prelim)
    (let/ec fail
      (for-each (match-lambda 
                  [`(,x ,y ,space-reqd) 
                    (when (< (spaces-around x y) space-reqd)
                      (fail #f))]
                  [else (error 'foo "gronk!")])
                constraints)
      (when (< (spaces-horiz 4 3) 3)
        (fail #f))
      (when (< (spaces-vert 4 8) 2)
        (fail #f))
      #t))
  
  (define (test-constraints/final)
    (let/ec fail
      (for-each (match-lambda 
                  [`(,x ,y ,space-reqd) 
                    (when (not (= (spaces-around x y) space-reqd))
                      (fail #f))]
                  [else (error 'foo "gronk!")])
                constraints)
      #t))
  
  (define horiz-incrementors
    (list (list (lambda (f x y) (f (- x 1) y))
                (lambda (x y) (>= x 0)))
          (list (lambda (f x y) (f (+ x 1) y))
                (lambda (x y) (< x m)))))
  
  (define vert-incrementors
    (list (list (lambda (f x y) (f x (- y 1)))
                (lambda (x y) (>= y 0)))
          (list (lambda (f x y) (f x (+ y 1)))
                (lambda (x y) (< y n)))))
  
  (define incrementors
    (append horiz-incrementors vert-incrementors))
  
  (define (spaces-around x y)
    (apply + (map (space-finder x y) incrementors)))
  
  (define (spaces-horiz x y)
    (apply + (map (space-finder x y) horiz-incrementors)))
  
  (define (spaces-vert x y)
    (apply + (map (space-finder x y) vert-incrementors)))
  
  (define (space-finder x y)
    (match-lambda 
      [`(,incr-func ,continue-func) 
        (letrec ([loop-fn 
                  (lambda (x y)
                    (if (and (continue-func x y) (blank (board-ref x y)))
                        (+ 1 (incr-func loop-fn x y))
                        0))])
          (incr-func loop-fn x y))]))
  
  (define (blank c)
    (if c
        (string=? c "White")
        #t))
  
  (define show-counter 0)
  (define show-how-often 100)
  
  (define total 0)
  (define start-time (current-milliseconds))
  
  (display
   (let/ec done
     (let loop ([pieces pieces])
       (if (null? pieces)
           (when (test-constraints/final)
             (done #t))
           (let* ([shape (car pieces)]
                  [color (shape-color shape)]
                  [configs (shape-configs shape)]
                  [key (shape-char shape)])
             (for-each (lambda (config)
                         (set! total (+ total 1))
                         (when (= total 10000)
                           (fprintf (current-error-port) "placements per second: ~v\n"
                                    (/ (* 1000 10000.0) (- (current-milliseconds) start-time)))
                           (set! start-time (current-milliseconds))
                           (set! total 0))
                         (find-a-place config
                                       key
                                       (lambda (xy)
                                         (place config (map->box config) xy color)
                                         (when (test-constraints/prelim)
                                           (loop (cdr pieces)))
                                         (unplace config (map->box config) xy))))
                       configs))))
     #f))
  
  (printf "~v\n" (spaces-around 7 3))
  )