Decaddance Rules in Clojure

gistfile1.clj

(ns decaddance.core
  (:require [clojure.math.numeric-tower :as math]
            [clojure.set :as set])
  (:use [midje.sweet]
        [clojure.core.match :only [match]]
        )
  )

(def origin [0 0])

; cardinal directions
(defn north [[x y]] [x (- y 1)])
(defn south [[x y]] [x (+ y 1)])
(defn east [[x y]] [(+ x 1) y])
(defn west [[x y]] [(- x 1) y])
(def orthagonal-adjacent-spaces (juxt north south east west))
(def cardinal-directions [north south east west])

(fact "cardinal directions return a space one removed in the direction of the function"
  (north origin) => [0 -1]
  (south origin) => [0 1]
  (west origin) => [-1 0]
  (east origin) => [1 0]
  )

; ordinal directions
(defn north-west [pos] (north (west pos)))
(defn north-east [pos] (north (east pos)))
(defn south-west [pos] (south (west pos)))
(defn south-east [pos] (south (east pos)))
(def ordinal-directions [north-west south-west north-east south-east])
(fact "ordinal directions are convenience functions for diagonals"
  (north-west origin) => [-1 -1]
  (south-west origin) => [-1 1]
  (north-east origin) => [1 -1]
  (south-east origin) => [1 1]
  (-> (north origin) north-west north-west west) => [-3 -3]
  )

(def compass-directions (into [] (concat cardinal-directions ordinal-directions) ))

(defn translate [[x y] [a b]] [(+ x a) (+ y b)])
(fact "translate sums the scalars in pos1 and pos2"
  (translate origin [2 2]) => [2 2]
  (translate [1 2] [3 4]) => [4 6]
  )

(defn vect [direction scale]
  (let [[x y] (direction origin)]
    [(* x scale) (* y scale)]
    )
  )
(fact "vect provides a point scale distance from origin in the direction provided"
  (vect south-east 2) => [2 2]
  )

(defn move [pos direction distance]
  (translate pos (vect direction distance)))
(fact "move should return a point translated by the vector from the supplied point"
  (move [1 2] south-east 2) => [3 4]
  )

(defn distance [[x1 y1] [x2 y2]]
  (math/sqrt (+ (math/expt (- x1 x2) 2) (math/expt (- y1 y2) 2))))
(fact "euclidean distance between 2 points"
  (distance origin [0 1]) => 1
  )


(defn orthagonally-adjacent? [pos1 pos2]
  (= (distance pos1 pos2) 1))

(fact "Orthagonal adjacency refers to the positions 1 space distant in the cardinal directions"
  (orthagonally-adjacent? origin [1 0]) => true
  (orthagonally-adjacent? origin [1 1]) => false ; diagonally adjacent - but not orthagonal
  )

(defn diagonally-adjacent? [[x1 y1] [x2 y2]]
  (and (= (math/abs(- x1 x2)) 1) (= (math/abs(- y1 y2)) 1)))
(fact "If the x difference and y difference are both 1 then the 2 given points are diagonally adjacent"
  (diagonally-adjacent? origin [1 0]) => false
  (diagonally-adjacent? origin [1 1]) => true ; diagonally adjacent - but not orthagonal
  )

(defn adjacent? [pos1 pos2]
  (or (diagonally-adjacent? pos1 pos2) (orthagonally-adjacent? pos1 pos2)))
(fact "Adjacency is defined as being either orthagonally or diagonally adjacent"
  (adjacent? origin [1 0]) => true
  (adjacent? origin [1 1]) => true ; diagonally adjacent - but not orthagonal
  (adjacent? origin [2 2]) => false ; 
  )
; list of adjacent spaces

; inbounds?
(defn inbounds? [[x y]  [[ulx uly] [lrx lry]]]
  (or (nil? x) (nil? y)) false
  (and (>= x ulx) (<= lrx) (>= y uly) (<= y lry))
  )
(fact "is pos within bounding box?"
  (inbounds? origin [[0 0] [1 1]]) => true
  (inbounds? origin [[1 1] [2 2]]) => false 
  )


; quad board is a map that takes [x y] as keys and has pieces as values
; and has rectangular bounds


; die piece {:team :value}
(def maxValue 6)
(def minValue 1)

(defn pieceDead? [{value :value}]
  (or (> value maxValue) (< value minValue)))
(fact "piece is dead if not in [1-6]"
  (pieceDead? {:value 7}) => true
  (pieceDead? {:value 0}) => true
  )

(defn orthagonal-adjacent-contents [board pos]  ;; ? should this contain nil?
  (select-keys board (orthagonal-adjacent-spaces pos))
  )


(let [board {origin {:team 1} [-1 0] {:team 1} [1 0] {:team 1} [2 0] {:team 1}}]
(fact "Non nil spaces orth adj to pos"
  (orthagonal-adjacent-contents board origin) => {[-1 0] {:team 1} [1 0] {:team 1}}
  )
)

(defn has-adjacency? [board pos]
  (->> (orthagonal-adjacent-contents board pos)
                 (count)
                 (< 0 )
                 )  
  )

(defn adjacent-team-pieces [board pos]
  "Give me a map {pos-n piece ...} where each piece has the same team as the piece at pos"
  (let [team (:team (board pos))
        m (orthagonal-adjacent-contents board pos)
        ]
      (into #{}
		    (keys
		      (select-keys m (for [[k v] m :when (= (:team v) team)] k))
		      )
      ) 
   )
)
(let [board {origin {:team 1} [-1 0] {:team 1} [1 0] {:team 2} [0 1] {:team 1}}]
(fact "Adjacent team pieces have the same team as the given position"
  (adjacent-team-pieces board origin) => #{[-1 0] [0 1]}
  )
)  

(defn spiderGroup [{:keys [board todoSet processedSet groupSet inclusion-function bounds], :or {bounds [[-1000 -1000] [1000 1000]] }}]
  "Starting with an inital pos in todoSet, collect a group of spaces. The inclusion-function takes a board and pos and returns positions that will be added to the todoSet"
  (let [pos (first todoSet)
         rest (rest todoSet)
        ]
	  (match [pos rest]
	         [nil _] groupSet ; no more todos - terminus
	    :else 
          (if (not(inbounds? pos bounds)) nil
	         (let [newTodos (set/difference (inclusion-function board pos) processedSet)
	               ]
            (recur {:board board 
                    :todoSet (set/union newTodos rest)
                    :processedSet (set/union newTodos processedSet) 
                    :groupSet (set/union groupSet #{pos})
                    :inclusion-function inclusion-function
                    :bounds bounds
                    })
            )
          )
  )
  )
)

(defn team-group [board pos]
  (spiderGroup {:board board :todoSet #{pos} :processedSet #{} :groupSet #{} :inclusion-function adjacent-team-pieces})
  )
(let [board {origin {:team 1} [-1 0] {:team 1} [1 0] {:team 2} [0 1] {:team 1}}]
	(fact "groupMap members will all be adjacent and belong to the same team"
    (team-group board [-1 0]) => #{[-1 0] [0 0] [0 1] }
	  )
 )

(defn adjacent-empty-spaces [board pos]  
  (into #{}
    (for [direction cardinal-directions
             :let [space (direction pos)]
             :when (nil? (board (direction pos)))]
         space)
    )
  )
(let [board {origin {:team 1 :value 3} [1 0] {:team 1 :value 3} [2 0] {:team 1 :value 4}}
      ]
	(fact "tridice are 3 continguous pieces in the given direction from the given point"
	  (adjacent-empty-spaces board [1 0]) => #{[1 -1] [1 1]} 
	  )
 )

(defn adjacent-same-team-or-nil [board pos]
  (set/union (adjacent-empty-spaces board pos) (adjacent-team-pieces board pos)
  )
  )

 
; TODO circumvallation?
; check adjacent pieces for another team
; group is same team or nil
; see if group space is outside of bounds

(defn encircledSet [board pos bounds]
  (->> (spiderGroup {:board board :todoSet #{pos} :processedSet #{} :groupSet #{} :inclusion-function adjacent-same-team-or-nil :bounds bounds})
    (remove #(nil? (board %)))
    (into #{})
    )
  )
(let [board {
             [0 -2] {:team 1 :value 4} [1 -2] {:team 1 :value 3} [2 -2] {:team 1 :value 4}
             [0 -1] {:team 1 :value 3} [1 -1] {:team 2 :value 3} [2 -1] {:team 1 :value 4}
             [0 0]  {:team 1 :value 1} [1 1]  {:team 1 :value 3} [2 0]  {:team 1 :value 4}
             }
      ]
	(fact "If the team group has no egress to the edge of the board, it is encircled."
	  (encircledSet board [1 -1] [[-2 -2] [2 2]]) => #{[1 -1]} 
	  (encircledSet board [1 1] [[-2 -2] [2 2]]) => #{} 
	  )
 )


(defn tridice-spaces [pos direction]
  [pos (direction pos) (direction (direction pos))]
  )
	(fact "given a pos, tridice-points are this pos and the next 2 pos in the indicated direction"
	  (tridice-spaces origin east) => [ [0 0] [1 0] [2 0]]
	  )

(defn tridice [board pos direction]
  (let [tridice-pieces (select-keys board (tridice-spaces pos direction)) 
        piece-count (count tridice-pieces) ]
    (match [piece-count]
        [3] tridice-pieces
        :else nil
        )
        )
  )
(let [board {origin {:team 1} [1 0] {:team 1} [2 0] {:team 1}}]
	(fact "tridice are 3 continguous pieces in the given direction from the given point"
	  (tridice board origin east) => {[2 0] {:team 1}, [1 0] {:team 1}, [0 0] {:team 1}}
	  )
 )

(defn sum-piece-values [pieces] 
  (->> (map #(get-in pieces [(first %) :value]) pieces)   
       (reduce +)
    )
  )

(let [pieces {origin {:team 1 :value 3} [1 0] {:team 1 :value 3} [2 0] {:team 1 :value 4}}]
	(fact "the result should be the sum of the :value's of the piecess"
	  (sum-piece-values pieces) => 10
	  )
 )

(defn score-tridice [ board pos direction]
  (let [tridice (tridice board pos direction) 
        sum (sum-piece-values tridice)
        team (:team (board pos))
        value (if tridice
						    (->> (map #(get-in tridice [(first %) :team]) tridice)
						      (map #(if (= team %) 1 2) )
						      (reduce +)
						    )
					      0
					     )
        ]
    (if (= sum 10) value (- value))
  )
 )

(let [board {origin {:team 1 :value 3} [1 0] {:team 1 :value 3} [2 0] {:team 1 :value 4}}
      board2 {origin {:team 2 :value 3} [1 0] {:team 2 :value 3} [2 0] {:team 1 :value 4}}
      board3 {origin {:team 1 :value 3} [1 0] {:team 2 :value 3} }
      board4 {origin {:team 1 :value 3} [1 0] {:team 2 :value 3} [2 0] {:team 1 :value 3}}
      ]
	(fact "tridice are 3 continguous pieces in the given direction from the given point"
	  (score-tridice board origin east) => 3
	  (score-tridice board2 origin east) => 4
	  (score-tridice board3 origin east) => 0
	  (score-tridice board4 origin east) => -4
	  )
 )


; if there is at least 1 decatridice - the score is positive - otherwise score
; the position as negative
(defn score-position [board pos]
    (let [middle-nw (score-tridice board (south-east pos) north-west)
          middle-ne (score-tridice board (south-west pos) north-east)
          middle-n (score-tridice board (south pos) north)
          middle-e (score-tridice board (west pos) east)
          scores (concat (map #(score-tridice board pos %) compass-directions) [middle-nw middle-ne middle-n middle-e])]
      (if (some #(> % 0) scores)
        (->> (filter #(> % 0) scores)
                     (reduce +))
        ;else
        (reduce + scores)
        )
      )
)
(let [board {
             [0 -2] {:team 1 :value 4} [1 -2] {:team 1 :value 3} [2 -2] {:team 2 :value 4}
             [0 -1] {:team 1 :value 3} [1 -1] {:team 1 :value 3} [2 -1] {:team 2 :value 4}
             [0 0]  {:team 1 :value 3} [1 0]  {:team 1 :value 3} [2 0]  {:team 2 :value 4}
             }
      board2 {
             [0 -2] {:team 1 :value 4} [1 -2] {:team 1 :value 3} [2 -2] {:team 2 :value 4}
             [0 -1] {:team 1 :value 3} [1 -1] {:team 1 :value 3} [2 -1] {:team 2 :value 4}
             [0 0]  {:team 1 :value 1} [1 0]  {:team 1 :value 3} [2 0]  {:team 2 :value 4}
             }
      ]
	(fact "tridice are 3 continguous pieces in the given direction from the given point"
	  (score-position board origin) => 11
	  (score-position board [1 -1] ) => 8
	  (score-position board2 origin) => -11
	  )
 )

(defn add-piece [board pos piece]
  (merge board {pos piece})
  )
(let [board {origin {:team 1} [1 0] {:team 1} [2 0] {:team 1}}]
	(fact "adding a piece results in a new board with the added piece"
	  (add-piece board [3 0] {:team 1}) => {[3 0] {:team 1} [2 0] {:team 1}, [1 0] {:team 1}, [0 0] {:team 1}}
	  )
 )

; legalMove?  for first die, 2nd-3rd
(defn legal-move? [board moves]
  (match [(count moves)]
         [0] false
         [1] (has-adjacency? board (first moves))
         [2] (and (has-adjacency? board (second moves)) (adjacent? (first moves) (second moves)))
         [3] (and (has-adjacency? board (last moves)) (or (adjacent? (first moves) (last moves)) (adjacent? (second moves) (last moves))))
         )
  )         
(let [board {
             [0 -2] {:team 1 :value 4} [1 -2] {:team 1 :value 3} [2 -2] {:team 2 :value 4}
             [0 -1] {:team 1 :value 3} [1 -1] {:team 1 :value 3} [2 -1] {:team 2 :value 4}
             [0 0]  {:team 1 :value 3} [1 0]  {:team 1 :value 3} [2 0]  {:team 2 :value 4}
             }
      board2 (add-piece board [-1 0] {:team 1 :value 4})
      board3 (add-piece board [0 1] {:team 1 :value 4})
      ]
	(fact "First legal move just needs to be adjacent to another piece.  2nd and 3rd need to be adjacent to previous moves this turn"
	  (legal-move? board []) => false
	  (legal-move? board [[-1 0]]) => true
	  (legal-move? board2 [[-1 0] [0 1]]) => true
	  (legal-move? board3 [[-1 0] [0 1] [0 2]]) => true
	  )
 )


; score-circumvallation - add to score pos