pentago.clj

(ns de.uni-potsdam.hpi.pentago)

(def empty-board
     [[:_____ :_____ :_____ :_____ :_____ :_____]
      [:_____ :_____ :_____ :_____ :_____ :_____]
      [:_____ :_____ :_____ :_____ :_____ :_____]
      [:_____ :_____ :_____ :_____ :_____ :_____]
      [:_____ :_____ :_____ :_____ :_____ :_____]
      [:_____ :_____ :_____ :_____ :_____ :_____]])

(def other-color 
     {:white :black
     :black :white})

(defn group-by
  "Applies f to each value in coll, splitting it each time f returns
   a new value.  Returns a lazy seq of lazy seqs."
  [f coll]
    (when-let [s (seq coll)]
      (let [fv (f (first s))
            [a b] (split-with #(= fv (f %)) s)]
        (lazy-cons a (group-by f b)))))


(defn partition-board [[[a1 a2 a3 a4 a5 a6]
			[b1 b2 b3 b4 b5 b6]
			[c1 c2 c3 c4 c5 c6]
			[d1 d2 d3 d4 d5 d6]
			[e1 e2 e3 e4 e5 e6]
			[f1 f2 f3 f4 f5 f6]]]
  (list
   [[a4 a5 a6]
    [b4 b5 b6]
    [c4 c5 c6]]
   [[d4 d5 d6]
    [e4 e5 e6]
    [f4 f5 f6]]
   [[d1 d2 d3]
    [e1 e2 e3]
    [f1 f2 f3]]
   [[a1 a2 a3]
    [b1 b2 b3]
    [c1 c2 c3]]))

(defn combine-board [[[a4 a5 a6] [b4 b5 b6] [c4 c5 c6]]
		     [[d4 d5 d6] [e4 e5 e6] [f4 f5 f6]]
		     [[d1 d2 d3] [e1 e2 e3] [f1 f2 f3]]
		     [[a1 a2 a3] [b1 b2 b3] [c1 c2 c3]]]
   [[a1 a2 a3 a4 a5 a6]
    [b1 b2 b3 b4 b5 b6]
    [c1 c2 c3 c4 c5 c6]
    [d1 d2 d3 d4 d5 d6]
    [e1 e2 e3 e4 e5 e6]
    [f1 f2 f3 f4 f5 f6]])

(defn turn-quadrant [[[A1 A2 A3]
		     [B1 B2 B3] 
		     [C1 C2 C3]]
		    direction]
     (cond 
      (= :counter direction)
      [[A3 B3 C3]
       [A2 B2 C2] 
       [A1 B1 C1]]
      (= :clockwise direction)
      [[C1 B1 A1]
       [C2 B2 A2] 
       [C3 B3 A3]]))

(defn ppr-board [[[a1 a2 a3 a4 a5 a6]
		  [b1 b2 b3 b4 b5 b6]
		  [c1 c2 c3 c4 c5 c6]
		  [d1 d2 d3 d4 d5 d6]
		  [e1 e2 e3 e4 e5 e6]
		  [f1 f2 f3 f4 f5 f6]]]
  (println  "      1      2      3        4      5      6")
  (println "A "    a1     a2     a3 "|"   a4     a5     a6)
  (println "B "    b1     b2     b3 "|"   b4     b5     b6)
  (println "C "    c1     c2     c3 "|"   c4     c5     c6)
  (println  "   ---------------------+---------------------")
  (println "D "    d1     d2     d3 "|"   d4     d5     d6)
  (println "E "    e1     e2     e3 "|"   e4     e5     e6)
  (println "F "    f1     f2     f3 "|"   f4     f5     f6))

(defn turn-board [board q d]
     (let [[I II III IV] (partition-board board)]
       ((q {:I #(combine-board (turn-quadrant I d) II III IV)
	   :II #(combine-board I (turn-quadrant II d) III IV)
	   :III #(combine-board I II (turn-quadrant III d) IV)
	   :IV #(combine-board I II III (turn-quadrant IV d))}))))

(defn put-piece [board row col piece]
  (let [row ({:A 0 :B 1 :C 2 :D 3 :E 4 :F 5} row)
	col (dec col)
	board (vec board)]
    (assoc board row (assoc (board row) col piece))))

;scoring
(defn scan-board [board]
  (let [rows board
	cols (apply map list board)
	diag (for [startrow (range 6)] (for [off (range 0 (- 6 startrow))]
					 ((board (+ startrow off)) off)))
	diag2 (for [startrow (range 1 6)] (for [off (range (- 6 startrow))]
					  ((board off) (+ startrow off))))
	diag3 (for [startrow (range 6)] (for [off (range (- 5 startrow) -1 -1)]
					  ((board (+ startrow off)) off)))
	diag4 (for [startrow (range 1 6)] (for [off (range (- 5 startrow) -1 -1)]
					  ((board off) (+ startrow off))))]
	(for [coll [rows cols diag diag2 diag3 diag4] 
		   line coll 
		   seq (group-by identity line)
		   :when (not (or (empty? seq) (= (count seq) 1) (= (first seq) :_____)))]
	       [(first seq) (count seq)])))

(defn calc-score [board-const color]
  (let [score-for (fn [c] (for [[color len] board-const :when (= c color)] (if (= 5 len) :win (* len len))))
	my-scores (score-for color)
	other-scores (score-for (other-color color))]
    (cond (contains? my-scores :win)
      (if (contains? other-scores :win)
	-20 ;draw
	:win)
      (contains? other-scores :win)
      :lose
      :else
      (apply - (apply + my-scores) other-scores))))

;moves
(defn valid-moves [board]
  (let [rowname [:A :B :C :D :E :F]]
    (for [row (range 6)
	  column (range 6)
	  :when (= :_____ ((board row) column))
	  quadrant [:I :II :III :IV]
	  direction [:clockwise :counter]]
      (list (rowname row) (inc column) quadrant direction))))
    
(defn make-move [board color row column quadrant direction]
  (-> board
      (put-piece row column color)
      (turn-board quadrant direction)))


;AI gameplay
(defn search-tree [board turn my-color depth]
  (if (zero? depth)
    (-> board
	(scan-board)
	(calc-score my-color))
    (let [subtree
	  (for [move (valid-moves board)]
	    (search-tree (apply make-move board turn move)
			 (other-color turn) my-color (dec depth)))]
      (if (= turn my-color)
	(loop [[score & rest] subtree bestscore (first subtree)]
	  (cond (= score :lose)
		(recur rest bestscore)
		(= score :win)
		score
		rest
		(if (> score bestscore)
		  (recur rest score)
		  (recur rest bestscore))
		:else bestscore))
	(loop [[score & rest] subtree bestscore  (first subtree)]
	  (cond (= score :win)
		(recur rest bestscore)
		(= score :lose)
		score
		rest
		(if (< score bestscore)
		  (recur rest score)
		  (recur rest bestscore))
		:else bestscore))))))

(defn best-move [board my-color depth]
 (sort (comparator (fn [[_ score1] [? score2]] (or (= score1 :win)
						   (= score2 :lose)
						   (and (integer? score1) 
							(integer? score2)
							(> score1 score2)))))
       (doall (for [move (valid-moves board)]
		(do
		  (prn move)
		  [move (search-tree (apply make-move board my-color move)
				     (other-color my-color) my-color (dec depth))])))))