codesamples/Scheme/wk3.ss

; testing for validity of solution BOOLEAN
(define (attack? state) 
  (or (horizontal? state)
      (diagonal? state)))

; are there horizontal attacks?
(define (horizontal? state)
  (let ((lst (vector->list state)))
    (dup? lst)))

; does the list contain duplicates?
(define (dup? lst)
  (if
   (null? lst)
   #f
   (if (and (<= 0 (car lst)) ; -1 doesn't matter
            (member (car lst) (cdr lst)))
       #t
       (dup? (cdr lst)))))

; are there diagonal attacks? pt 1
(define (diagonal? state)
  (let ((lst (vector->list state)) (n (vector-length state)))
    (if (null? lst)
        #f
        (or 
         (diagonal2? lst (- n 1))
         (diagonal? (list->vector (cdr lst)))))))

; diagonal? pt 2
(define (diagonal2? lst n)
  (if (= n 0) 
      #f
      (let* ((elem (list-ref lst n)) (nonneg (not (or (= -1 (car lst)) (= -1 elem)))))
        (or
         (and (eqv? (car lst) (+ elem n)) nonneg)
         (and (eqv? (car lst) (- elem n)) nonneg)
         (diagonal2? lst (- n 1))))))


; testing for validity of solution NUMBER OF ATTACKS
(define (attacks state col)
  (+ (horizontals state col)
     (diagonals state col)))

; Horizontal attacks
(define (horizontals state col)
  (let ((lst (vector->list state)))
    (dups lst col)))

; Diagonal attacks wrapper
(define (diagonals state col)
  (let ((lst (vector->list state)) (n (vector-length state)))
    (if (null? lst)
        0
        (let* ((elem (list-ref lst col)) ; current value of the column I'm working with
               (newlst (list-mute lst col -1))) ; unassign the column I'm working with
          (diagonals2 newlst elem (- (- n 1) col) col))))) ; (n-1)-col = max distance a diagonal attack can be

; Diagonal attacks recursive core
(define (diagonals2 lst elem dist col)
  (if (= 0 dist)
      0
      (if (> (- col dist) 0) ; if there are two possible diagonals
          (let ((elem1 (list-ref lst (+ col dist))) ; the element n ahead - check for being n more or n less
                (elem2 (list-ref lst (- col dist)))) ; the element n behind - check for being n more or n less
            (if (and 
                 (or (= elem1 (+ elem dist)) (= elem1 (- elem dist)))
                 (or (= elem2 (+ elem dist)) (= elem2 (- elem dist))))
                (+ 2 (diagonals2 lst elem (- dist 1) col)) ; if both, add 2 and recurse
                (if (or 
                     (or (= elem1 (+ elem dist)) (= elem1 (- elem dist)))
                     (or (= elem2 (+ elem dist)) (= elem2 (- elem dist))))
                    (+ 1 (diagonals2 lst elem (- dist 1) col)) ; if one, add 1 and recurse
                    (diagonals2 lst elem (- dist 1) col)))) ; else, recurse
          (let ((elem1 (list-ref lst (+ col dist)))) ; only one possible diagonal from here
            (if (or (= elem1 (+ elem dist)) (= elem1 (- elem dist))) ; check for being n more or n less
                (+ 1 (diagonals2 lst elem (- dist 1) col)) ; if so, add 1 and recurse
                (diagonals2 lst elem (- dist 1) col))))))

; Number of duplicates wrapper
(define (dups lst col)
  (let ((elem (list-ref lst col))
        (newlst (list-mute lst col -1)))
    (if (null? lst)
        0
        (appears elem newlst))))

; Number of duplicates recursive core
(define (appears elem lst)
  (if (null? lst)
      0
      (if (eqv? (car lst) elem)
          (+ 1 (appears elem (cdr lst)))
          (appears elem (cdr lst)))))

; are there no attacks and are there any -1 (unassigned) columns?
(define (valid? state)
  (and 
   state
   (not (attack? state))
   (not (member -1 (vector->list state)))))

; select new column as equal to the search level
; mode 1 = in order
; mode 2 = inside out
; mode 3 = outside in
(define (select-new-column level length mode)
  (if (= mode 1)
      level
      (if (= mode 2)
          (inside-out level length)
          (outside-in level length))))

; select columns from the inside out
(define (inside-out level length)
  (if (= level length)
      (- level 1)
      (if (even? level)
          (+ (floor (/ length 2)) (/ level 2))
          (- (floor (/ length 2)) (/ (+ level 1) 2)))))

; select columns from the outside in
(define (outside-in level length)
  (if (= level length)
      (floor (/ level 2))
      (if (odd? level)
          (- length (/ (+ 1 level) 2))
          (- length (- length (/ level 2))))))

; Backtracking!
; initialize steps & level as 0
; state should be initialized all -1 (queengen does this)
; colmode: 1 is 0 to N, 2 is inside out (doesn't work), 3 is outside in
(define (backtrack state steps level colmode)
  ;(print (list state steps)) ; diagnostic
  (if (valid? state)
      (list state steps)
      (let* ((len (vector-length state))
             (col (select-new-column level len colmode)))
        (if (= level len) ; if past the last column
            (if (valid? state) ; if success, return - else fail
                (list state steps)
                (list #f steps))
            (let* ((newcol (select-new-column (+ level 1) len colmode)) ; if not past the last column, get new column
                   (queen (recur-row state newcol -1)))
              (if (= queen -1)
                  (list #f steps)
                  (let* ((nextstate (vector-mute state newcol queen)) ; try the next column
                         (result (backtrack nextstate (+ 1 steps) (+ level 1) colmode)))
                    (if (car result) ; if state successful, return
                        result
                        (let ((elem (+ 1 (vector-ref state col))) ; else find next queen
                              ; number of steps is extra since result + current
                              (newsteps (+ (abs (- (cadr result) steps)) steps)))
                          (if (>= elem (- len 1)) ; if new queen is off the board, fail
                              (list #f newsteps)
                              (let ((newstate (vector-mute state col elem))) ; else try this column again
                                (backtrack newstate (+ newsteps 1) level colmode))))))))))))

; make a board state where all = -1
; except the first, which = 0
(define (queengen n)
  (let ((vec (make-vector n -1))) 
    (vector-mute vec 0 0)))

; test the validity of putting a queen in each row of a column
; picks the first row that generates no attacks
; used in backtracking
; intial call should have row == -1
(define (recur-row state col row) 
  (if (< row 0) ; if we're just starting
      (let ((newstate (vector-mute state col 0))) ; set the row value of col to 0
        (recur-row newstate col 0))
      (if (>= row (vector-length state)) ; if we're past the end then I can't put a queen anywhere
          -1 ; and should unassign the column
          (if (not (attack? state))
              row
              (let ((newstate (vector-mute state col (+ 1 row))))
                (recur-row newstate col (+ 1 row))))))) ; try the next row in this column


; utility function - returns a new list of same length as input
; element in <col> will be <val>, all the rest will be the same as original
(define (list-mute lst col val)
  (if (= 0 col)
      (cons val (cdr lst)) ; if I want the first element in the list
      (cons (car lst) (list-mute (cdr lst) (- col 1) val)))) ; if I want a later element

; apply list-mute to a vector - simple wrapper
(define (vector-mute vec col val)
  (if (= col (vector-length vec))
      vec
      (list->vector (list-mute (vector->list vec) col val))))


; ~~~~~ Min-Conflicts! ~~~~~
; initialize lastcol to -1 and steps to 0
(define (min-conflicts state lastcol steps maxsteps)
  ;(print (list state steps)) ; diagnostic
  (if (= maxsteps 0) ; if we're out of steps
      (list #f steps) ; failz0rz
      (if (valid? state) 
          (list steps) ; you are a winnar!
          ; you are not a winnar - please try again
          (let* ((col (select-conflicting-column state lastcol 0)) ; pick a column with conflicts
                 (row (least-conflicts state col)) ; and the row in it with fewest conflicts
                 (newstate (vector-mute state col row))) ; and make a new state
            (min-conflicts newstate col (+ steps 1) (- maxsteps 1)))))) ; and iterate!

; ~~~~~ Randomly initialize board states ~~~~~

; initialize a board state greedily (has element of randomnity)
; wrapper
(define (initialize-g n)
  (let ((state (make-vector n 0)))
    (init-greedy state 0)))

; recursive core
(define (init-greedy state col)
  (if (= col (vector-length state))
      state
      (let* ((row (least-conflicts state col))
             (newstate (vector-mute state col row)))
        (init-greedy newstate (+ 1 col)))))

; initialize a board state randomly - wrapper
(define (initialize-r n)
  (let ((state (make-vector n 0)))
    (init-random state 0)))

; recursive core
(define (init-random state col)
  (if (= col (vector-length state))
      state
      (let* ((row (random (vector-length state)))
             (newstate (vector-mute state col row)))
        (init-random newstate (+ 1 col)))))


; select random conflicting column
(define (select-conflicting-column state lastcol level)
  (let ((col (random (vector-length state))))
    (if (or (and (< 0 (attacks state col)) (not (= col lastcol))) (= level 10))
        col
        (select-conflicting-column state lastcol (+ level 1)))))

; select column with most conflicts - no good
(define (select-conflictingest-column state col)
  (if (= col (- (vector-length state) 1))
      (attacks state col)
      (let* ((current (attacks state col))
             (futurecol (select-conflictingest-column state (+ 1 col)))
             (future (attacks state futurecol)))
        (if (> current future)
            col
            futurecol))))

; choose the row in col that generates the fewest conflicts
(define (least-conflicts state col)
  (let ((base (vector-mute state col 0)))
    (least-cons base 0 col)))

(define (least-cons state row col)
  (if (= row (vector-length state))
      (attacks state col)
      (let* ((newstate (vector-mute state col (+ 1 row)))
             (current (attacks state col))
             (futurerow (least-cons newstate (+ 1 row) col))
             (futurestate (vector-mute state col futurerow))
             (future (attacks futurestate col)))
        (if (< future current) 
            futurerow
            (coinflip futurerow row)))))


; choose randomly between two objects
(define (coinflip obj1 obj2)
  (let ((coin (random)))
    (if (< 0.5 coin)
        obj1
        obj2)))

; Program wrapper
; mode b = backtracking
; mode mg = min-conflicts with greedy initialization
; else = min-conflicts with random initialization
(define (n-queens n mode maxsteps)
  (if (eqv? mode "b")
      (backtrack (queengen n) 0 0 1) ; 0 to N
      (if (eqv? mode "mg")
          (min-conflicts (initialize-g n) -1 0 maxsteps)
          (min-conflicts (initialize-r n) -1 0 maxsteps))))

; data-collection helper functions
(define (collect-me-some-data-mg maxn minn maxsteps)
  (do ((n maxn (- n 1))) ((< n minn))
      (printf "~a: ~s \n" n (min-conflicts (initialize-g n) -1 0 maxsteps))))

(define (collect-me-some-data-mr maxn minn maxsteps)
  (do ((n maxn (- n 1))) ((< n minn))
      (printf "~a: ~s \n" n (min-conflicts (initialize-r n) -1 0 maxsteps))))

(define (collect-me-some-data-b maxn minn colmode)
  (do ((n maxn (- n 1))) ((< n minn))
      (printf "~a: ~s \n" n (backtrack (queengen n) 0 0 colmode))))