Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: MarcoPolo/beadgame
base: 07f6890a8d
...
head fork: MarcoPolo/beadgame
compare: 00e56d408d
  • 2 commits
  • 8 files changed
  • 0 commit comments
  • 1 contributor
Commits on Dec 07, 2012
Marco Munizaga removed useless files 021939b
Marco Munizaga updated readme 00e56d4
View
11 README.md
@@ -7,14 +7,21 @@ All the ladies love Clojure!
## Usage
+You can run the already built jar
+ ` java -jar target/beadgame-3.0-standalone.jar `
+
+Or
+
To compile the code and package it into a jar, just run:
` lein uberjar `
-The you can just run the standalone jar that's included in the target.
+Then you can just run the standalone jar that's included in the target.
` java -jar target/beadgame-3.0-standalone.jar `
-When you start the game it will ask you for an initial board file, this board file is a space delimited columns, new lime delimited rows. You can use any colours.
+
+When you start the game it will ask you for an initial board file, this board file is a space delimited columns, new line delimited rows. Specify a color from A-Z (caps) if you want a visual guide.
Example initial boards are provided as startBoard, startBoard2 ...
+Test boards are under test-boards/
The game will explain the rest of the instructions
View
2  project.clj
@@ -3,5 +3,5 @@
:license {:name "GPL"
:url "http://www.gnu.org/licenses/gpl.html"}
:dependencies [[org.clojure/clojure "1.4.0"] [criterium "0.3.1"] [quil "1.6.0"]]
- :main beadgame.chainshot3)
+ :main beadgame.chainshot )
View
796 src/beadgame/chainshot.clj
@@ -1,177 +1,679 @@
+;; So here is the third iteration that involves no state to operate
+;; Although we are going to have a single unit of state to make the game playaple it isn't required
+;; and in fact not used for the AI algorithms
+
(ns beadgame.chainshot
+ (:use [criterium.core]
+ [quil.core])
(:gen-class))
-(def rowLength 5)
-(def colLength 5)
-
(defmacro dbg[x] `(let [x# ~x] (println "dbg:" '~x "=" x#) x#))
-(defn getRow [boardState index]
- (vec (map #(try (%1 index) (catch Exception e " ")) boardState)))
+;; Simple atom to keep state.
+(def graph-atom (atom nil))
-(defn getCol [boardState index]
- (boardState index))
+(comment
+ (def sample-graph ^{:bound-limit 5} {
+ 4 { 0 "g" 1 "g" 2 "r" 3 "r" 4 "g" }
+ 3 { 0 "g" 1 "g" 2 "r" 3 "r" 4 "g" }
+ 2 { 0 "g" 1 "g" 2 "b" 3 "r" 4 "g" }
+ 1 { 0 "r" 1 "g" 2 "g" 3 "r" 4 "g" }
+ 0 { 0 "r" 1 "g" 2 "g" 3 "r" 4 "r" }})
-(defn printBoard [boardState]
- (doseq [ y (reverse (range rowLength)) ]
- (println (getRow boardState y))))
+ (def sample-pos ^"Position is [x y]" [0 4])
+ (comment "First part pertains to the col no* and the second part pertains to row number")
+ (= (get-in sample-graph sample-pos) "r")
+ (print-graph sample-graph)
-(defn getColor [boardState x y]
- ((getCol boardState y) x))
+ (def bound-limit (:bound-limit (meta sample-graph) ))
-(defn removeRange [colorSeries start end]
-
- (reduce conj (subvec colorSeries 0 start) (subvec colorSeries (inc end))))
+ (reduce #(and %1 %2) (map pos? [0 1]))
+ (ns beadgame.chainshot3)
-
-(defn forwardWalk [colorSeries startPosition color]
- (loop [position startPosition]
- (if (not= (colorSeries position) color)
- (dec position)
- (if (< (inc position) (count colorSeries))
- (recur (inc position))
- position))))
+ )
-(defn reverseWalk [colorSeries startPosition color]
- (- (count colorSeries) (inc (forwardWalk (vec (reverse colorSeries)) (- (count colorSeries) (inc startPosition)) color ))))
+(comment
+ (def test8 (print-graph (read-file "testBoard8")))
+ (def test5 (print-graph (read-file "test5")))
+ bound-limit
+ )
-(defn findRange [colorSeries startPosition color]
- [(reverseWalk colorSeries startPosition color) (forwardWalk colorSeries startPosition color)])
+(defn read-file
+ "Reads a file and outputs a graph, also sets the global bound limit"
+ [filename]
+ (->
+ (slurp filename)
+ (clojure.string/split #"\n")
+ (count)
+ (#(def bound-limit %)))
+
+ ( loop [ characters (->
+ (slurp filename)
+ (clojure.string/split #"\s"))
+ graph (apply merge {} (for [x (range bound-limit)] [x {}]))
+ positions (for [y (reverse (range bound-limit)) x (range bound-limit) ] [x y])]
+ (if (seq characters)
+ (recur
+ (rest characters)
+ (assoc-in graph (first positions) (first characters))
+ (rest positions))
+ graph)))
+
+
+(defn bounded? [bound-limit position]
+ "Returns the position if it is within the 0 < position < bound-limit
+ Else returns false"
+ (if (->>
+ position
+ (map #(and (<= 0%) (< % bound-limit)) )
+ (reduce #(and %1 %2)))
+ position
+ false))
+
+(defn goto-neighbor-with-limit
+ [bound-limit position direction]
+ (if-let[ new-position (bounded?
+ bound-limit
+ (condp = direction
+ :up (update-in position [0] inc)
+ :down (update-in position [0] dec)
+ :left (update-in position [1] dec)
+ :right (update-in position [1] inc)))]
+ new-position
+ nil))
+
+
+(defn goto-neighbor
+ [graph position direction]
+ (goto-neighbor-with-limit bound-limit position direction))
+
+(defn read-neighbor
+ [graph position direction]
+ (get-in graph (goto-neighbor graph position direction)))
+
+(defn pieces-left [graph]
+ (->>
+ (vals graph)
+ (map vals)
+ (map count)
+ (reduce +)))
+
+(defn find-cluster
+ ([graph position]
+ (let [value (get-in graph position)
+ cluster (first (find-cluster graph position value [] []))]
+ (if (< 2 (count cluster))
+ cluster
+ [])))
+
+ ([graph position value cluster visited]
+ (let [ directions [:up :down :left :right]
+ neighbors (map #(goto-neighbor graph position % ) directions)]
+ (if (and
+ (not (nil? position))
+ (not (nil? value))
+ (= value (get-in graph position))
+ (not (some #{position} visited)))
+ ;(conj (map #(find-cluster graph % value (conj visited position)) neighbors) position)
+ (->>
+ [(conj cluster position) (conj visited position) ]
+ (apply find-cluster graph (nth neighbors 0) value)
+ (apply find-cluster graph (nth neighbors 1) value)
+ (apply find-cluster graph (nth neighbors 2) value)
+ (apply find-cluster graph (nth neighbors 3) value))
+
+
+ [cluster (conj visited position)]))))
+
+
+(defn shift-graph-changes
+ [graph nodes]
+ ; Get the cols that have changed
+ (let [changed-cols (map first nodes)]
+ [(loop [graph graph changed-cols changed-cols]
+ (if (seq changed-cols)
+ (recur
+ (->>
+ (get graph (first changed-cols))
+ (#(remove nil? (map % (range bound-limit))))
+ (zipmap (range bound-limit))
+ (assoc graph (first changed-cols)))
+ (rest changed-cols))
+ graph))
+ nodes]))
+
+(defn shift-graph-cols
+ [graph nodes]
+ [(->>
+ (for [row (range bound-limit)] (graph row))
+ (remove empty?)
+ (zipmap (range bound-limit)))
+ nodes])
+
+
+
+(defn remove-nodes
+ ([graph nodes]
+ [(loop [graph graph nodes nodes]
+ (if (seq nodes)
+ (recur
+ (assoc-in graph (first nodes) nil)
+ (rest nodes))
+ graph))
+ nodes]))
+
+(map #(print " " %) (range bound-limit))
+
+(defn print-graph
+ ([graph]
+ ;;print the top row first and work your way down
+ (doseq [y (reverse (range bound-limit)) x (range bound-limit) :let [node (get-in graph [x y])] ]
+ (if (zero? x) (do (println) (print (inc y))))
+ (print " " (if (nil? node) " " node)))
+ (println)
+ (print " ")
+ (doseq [ x (range bound-limit) ] (print " " (inc x)))
+ (println)
+ graph)
+ ([graph & more]
+ (print-graph graph)
+ ;; Echo back original args for chaining purposes
+ (conj more graph)))
+
+(defn calculate-points
+ [cluster]
+ (if (> (count cluster) 2)
+ (Math/pow (- (count cluster) 2) 2)
+ 0.0))
+
+(defn choose-move
+ [graph cluster]
+ [ (->>
+ [graph cluster]
+ (apply remove-nodes)
+ (apply shift-graph-changes)
+ (apply shift-graph-cols)
+ ((fn [[graph nodes]] graph)))
+ (calculate-points cluster)])
-(defn filterColumns [boardState startCol endCol x y color]
- (loop [currentCol startCol newCols (subvec boardState 0 startCol) ]
- ( if (<= currentCol endCol)
+
+(defn find-all-clusters
+ [graph]
+ (loop [ possible-moves (for [x (range bound-limit) y (range bound-limit)] [x y])
+ cluster-positions #{}
+ clusters []
+ graphs []
+ points [] ]
+ (cond
+ (nil? (seq possible-moves)) (map vector graphs clusters points)
+ (nil? (get-in graph (first possible-moves)))
(recur
- (inc currentCol)
-
- (let [colorSeries (getCol boardState currentCol) [removeStart removeEnd] (findRange colorSeries x color)]
- (conj newCols (removeRange colorSeries removeStart removeEnd ))))
- ( filter #(seq %)
- (reduce conj newCols (subvec boardState (inc endCol)))))))
-
-(defn chooseMove [boardState x y]
- "User's action on clicking the spot in the board"
- ; First we need to calculate which columns are affected
- ; then we will calculate which part of the columns are affected and modify the vector accordingly. this will modify each part of the row
- ; When we find an empty vector we get rid of it
-
- (try
- (let [ color (getColor boardState x y)
- [startCol endCol] (findRange (getRow boardState x) y color) ]
- (vec (filterColumns boardState startCol endCol x y color)))
- (catch Exception e boardState)))
+ (rest possible-moves)
+ (conj cluster-positions (first possible-moves))
+ clusters
+ graphs
+ points)
+ (nil? (cluster-positions (first possible-moves)))
+ ;; We haven't added this position as part of a previous cluster
+ (let [new-cluster (find-cluster graph (first possible-moves))
+ move (choose-move graph new-cluster)
+ new-graph (first move)
+ new-points (second move)]
+ (def c new-cluster)
+ ;;check to see if the new-cluster is invalid
+ (if (nil? (seq new-cluster))
+ (recur
+ (rest possible-moves)
+ cluster-positions
+ clusters
+ graphs
+ points)
+ (recur
+ (rest possible-moves)
+ (apply conj cluster-positions new-cluster) ;; Add the cluster to our set of visited nodes
+ (conj clusters new-cluster)
+ (conj graphs new-graph)
+ (conj points new-points))))
+ :else (recur
+ (rest possible-moves)
+ cluster-positions
+ clusters
+ graphs
+ points))))
+
+(defn execute-moves
+ "Simple way to view moves being executed"
+ [graph moves graph-atom & {:keys [time-delay] :or {time-delay 1000}}]
+ (loop [moves moves graph graph points 0]
+ (Thread/sleep time-delay)
+ (if (seq moves)
+ (let [new-cluster (find-cluster graph (first moves))
+ move (choose-move graph new-cluster)
+ new-graph (first move)
+ new-points (second move)]
+ (print-graph new-graph)
+ (reset! graph-atom new-graph)
+ (println "Points: " (+ new-points points))
+ (recur
+ (rest moves)
+ new-graph
+ (+ points new-points)))
+ nil)))
+
+(defn filter-moves
+ "If a move doesn't do anything we can filter it out
+ Useful for outputting the final set of moves"
+ [graph moves]
+ (loop [graph graph moves moves filtered-moves []]
+ (if (seq moves)
+ (let [new-cluster (find-cluster graph (first moves))
+ move (choose-move graph new-cluster)
+ new-graph (first move)]
+ (if (seq new-cluster)
+ ;; We have a valid move
+ (recur new-graph (rest moves) (conj filtered-moves (first new-cluster)))
+ ;; We don't have a valid move
+ (recur graph (rest moves) filtered-moves)))
+ filtered-moves)))
+
+(defn input-position-bounded? [[x y]]
+ (if (bounded? bound-limit [x y])
+ [x y]
+ (do (println "Sorry the position is out of the range") nil)))
+
+(defn input-valid? [graph [x y]]
+ (if (get-in graph [x y])
+ [x y]
+ (do (println "sorry there is nothing there" nil))))
+
+(defn cluster-valid? [graph [x y]]
+ (if (seq (find-cluster graph [x y]))
+ [x y]
+ (do (println "The cluster is too small") nil)))
+
+(defn valid-move? [graph position]
+ (and (input-position-bounded? position)
+ (input-valid? graph position)
+ (cluster-valid? graph position)))
+
+(defn prompt-move [graph]
+ (println "Pick your move x y")
+ (let [position (map dec (map read-string (clojure.string/split (read-line) #" ")))]
+ (println position)
+ (if (valid-move? graph position)
+ (vec position)
+ (prompt-move graph))))
+
+(defn prompt-graph []
+ (println "Type in the board-file")
+ (read-file (read-line)))
+
+(defn finished-game [points]
+ (println "Congrats you finished the game with: " points "points!"))
+
+(declare prompt-play-again)
+
+(defn human-playing []
+ (loop [graph (prompt-graph) points 0]
+ (print-graph graph)
+ (println "Points: " points)
+ (reset! graph-atom graph)
+ (let [move-position (prompt-move graph)
+ cluster (find-cluster graph move-position)
+ [new-graph new-points] (choose-move graph cluster)]
+ (if (seq (find-all-clusters new-graph))
+ (recur new-graph (+ points new-points))
+ (do (finished-game (+ points new-points)) (prompt-play-again))))))
+
+(defn prompt-play-again []
+ (println "Play Again (y/n)")
+ (condp = (read-line)
+ "y" (do (println "playing again!") (human-playing))
+ "n" (println "not playing again!")
+ (do (println "Please choose either y or n") (prompt-play-again))))
+
+
+(comment
+ test5
+ (reset! graph-atom test5)
+ (build-visual-aid graph-atom)
+ (prompt-graph)
+ (human-playing)
+ (breadth-search [sample-graph [] 1])
+
+ )
+
+
+
+;; Genetic algorithms
+
+(defn initialize
+ "Returns randomly generated points that will be used to pick clusters
+ Lets call it a strand"
+ [length]
+ (repeatedly length (fn [] [(rand-int bound-limit) (rand-int bound-limit)])))
+
+(defn generate-strands
+ [strand-count strand-length]
+ (take strand-count ( repeatedly #( initialize strand-length ))))
+
+(defn fitness
+ "calculates the fitness of strand"
+ [graph strand]
+ (loop [strand strand graph graph points 0]
+ (if (seq strand)
+ (let [move (->>
+ (find-cluster graph (first strand))
+ (choose-move graph))
+ new-graph (first move)
+ points (+ points (second move))]
+ (recur
+ (rest strand)
+ new-graph
+ points))
+ points)))
+
+
+(defn crossover
+ [strand1 strand2]
+ (apply conj
+ (vec (take (rand-int (count strand1)) strand1))
+ (take (inc (rand-int (dec (count strand2)))) strand2)))
+
+(defn simple-mutate
+ [strand]
+ (if (< 0.70 (rand))
+ (initialize 1)
+ strand))
+
+(defn roulette-wheel-selection
+ [strands fitness-values times]
+ (let [strands (map vector strands fitness-values)
+ sorted-strands (sort-by #(* -1 (second %)) strands)
+ sum (reduce + fitness-values)
+ normalized-strands (map #(vector (first %) (/ (second %) sum)) sorted-strands)
+ accumulated-strands (loop [normalized-strands normalized-strands accumulated-strands [] running-sum 0]
+ (if (seq normalized-strands)
+ (recur
+ (rest normalized-strands)
+ (conj accumulated-strands (update-in (first normalized-strands) [1] #(+ running-sum %)))
+ (+ running-sum (second (first normalized-strands)) ))
+ accumulated-strands))]
+ (take times (repeatedly #(first (filter (fn [strand] (let [r (rand)] (> (second strand) r))) accumulated-strands))))))
+
+(defn breed-strands
+ [strands children-count]
+ (take children-count (repeatedly #(-> (crossover (rand-nth strands) (rand-nth strands))
+ (simple-mutate)))))
+
+
+(defn circle-of-life
+ "Function that composes all the parts of the genetic algorithm
+
+ population-count - How many different strands should exist
+ strand-length - How long each strand should be ( a strand is a set of moves
+ iteration-count - How many iterations to go through
+ selection-ratio - Select what percentage of the initial population for future use
+
+ "
+
+ [graph & {:keys [population-count strand-length iteration-count selection-ratio]
+ :or {population-count 100 strand-length 20 iteration-count 20 selection-ratio 0.1 }}]
+ (let [initial-population ( generate-strands population-count strand-length)]
+ (loop [population initial-population iteration iteration-count max-strand [[] 0]]
+ (println "iteration" iteration)
+ (if (pos? iteration)
+ (let [fitness-values (pmap (partial fitness graph) population)
+ new-population (-> (map first (roulette-wheel-selection population fitness-values (int (* population-count selection-ratio))))
+ (breed-strands population-count))
+ new-max-strand (apply max-key second (map vector population fitness-values))]
+ (println "Fitness so far:" (take 5 fitness-values))
+ (recur new-population (dec iteration) (max-key second new-max-strand max-strand)))
+ max-strand))))
+
+
+
+(defn build-visual-aid [graph-atom]
+
+ (defn setup []
+ (smooth)
+ (frame-rate 10)
+ (background 200))
+
+ (def color-map (zipmap (map str (map char (range 65 91) ))
+ (repeatedly #(map (fn [a] (rand-int 256)) (range 3)))))
+ (def color-map (assoc color-map nil '(200)))
+
+ (defn draw []
+ (stroke 200)
+ (stroke-weight 10)
+ (fill (random 255))
+ (if (nil? @graph-atom)
+ (background 200)
+
+ (let [graph @graph-atom diam (/ 800 bound-limit)]
+ (doseq [y (reverse (range bound-limit)) x (range bound-limit) :let [ [plot-x plot-y] (map #(+ (/ 800 bound-limit 2) (* (/ 800 bound-limit) %)) [x y])
+ node (get-in graph [x y])] ]
+ (apply fill (color-map node))
+ (ellipse plot-x (- 800 plot-y) diam diam) ))))
+
+
+ (defsketch example ;;Define a new sketch named example
+ :title "Beadgame!" ;;Set the title of the sketch
+ :setup setup ;;Specify the setup fn
+ :draw draw ;;Specify the draw fn
+ :size [800 800]))
+
+
+
+(defn demo-genetic-algorithm []
+
+ (doseq [graph-name [
+ "test-boards/test1"
+ "test-boards/test2"
+ "test-boards/test3"
+ "test-boards/test4"
+ "test-boards/test5"
+ "test-boards/test6"
+ "test-boards/test7"
+ "test-boards/test8"
+ "test-boards/test9"
+ "test-boards/test10"
+ "test-boards/test11"]
+ :let [graph (read-file graph-name)]]
+ (println "Testing" graph-name)
+ (let [[time-dur [moves points]]
+ (time-body
+ (circle-of-life
+ graph
+ :population-count 50
+ :strand-length 150
+ :iteration-count 20
+ :selection-ratio 0.3))]
+
+
+ (reset! graph-atom nil)
+ (reset! graph-atom graph)
+
+ (execute-moves graph (filter-moves graph moves) graph-atom :time-delay 10)
+ (println "Points: " points)
+ (println "Time: " time-dur)
+ (println "Pieces left: " (pieces-left @graph-atom)))))
-(defn unskewInput [skewedBoard]
- (loop [board [] skewedBoard skewedBoard colNo 0]
- (if (>= colNo (count skewedBoard))
- board
- (recur (conj board (vec (reverse (map #(% colNo) skewedBoard)))) skewedBoard (inc colNo)))))
-(defn readFile
- "Read the file starting board file"
- [filename]
- (let [filecontents (slurp filename)]
- (println "Reading file" filename)
- (unskewInput
- (vec
- (map #(clojure.string/split % #"\s")
- (clojure.string/split-lines filecontents))))))
-
-
-(defn piecesLeft [boardState]
- ; count the pieces left
- (reduce #(+ %1 (count %2)) 0 boardState))
-
-
-(defn calculatePoints [currentState nextState]
- (let [delta (- (piecesLeft currentState) (piecesLeft nextState))]
- (if (< 2 delta)
- (Math/pow (- delta 2) 2)
- 0 )))
-
-(defn keepPlaying [currentState]
- (let [startPieceCount (piecesLeft currentState)]
- (reduce #(or %1 %2)
- (map #(< 1 %)
- (try
- (map #(- startPieceCount (piecesLeft (apply chooseMove %)))
- (for [x (range colLength) y (range rowLength) ] [currentState x y]))
- (catch Exception e 0))))))
-
-(defn printRules []
- (println "The rules are really difficult so you might want to take notes")
- (println "Specify your move in the format of: X Y")
- (println "Where X is the row counting from the bottom")
- (println "and Y is the column counting from the left")
- (println "You want to make a move somewhere with a group of colours, given that group is > 1 ")
- (println "After you pick a move I will calculate how many points you \"deserve\"")
- (println "After you have exhausted all the moves, the game is over and at least one of us will be dissapointed"))
+
+
(comment
- (printBoard currentState)
- (println (readFile "startBoard"))
- currentState
- file
- (keepPlaying currentState)
- (def currentState (readFile "startBoard"))
- (slurp "startBoard")
- (def asdf (getPossibleMoves currentState))
+ ;;clear the board if we are showing it
+ (reset! graph-atom nil)
+
+ (println "Testing test 11")
+ (def test11 (print-graph (read-file "test11")))
+ (def moves (circle-of-life test11 :population-count 50 :strand-length 50 :iteration-count 20 :selection-ratio 0.8))
+ (println "Points for test 11" (second moves))
+ (reset! graph-atom test11)
+ (execute-moves test11 (filter-moves test11 (first moves)) graph-atom :time-delay 300)
+
+ )
+(defn benchmark-genetic-algorithm []
+ (println "Benchmarking test 11")
+ (def test5 (print-graph (read-file "test5")))
+ (with-progress-reporting (bench
+ (circle-of-life test5 100 40 20 0.3)))
+ (println "Benchmarking test 5")
+ (def test11 (print-graph (read-file "test11")))
+ (with-progress-reporting (bench
+ (circle-of-life test11 100 40 20 0.3))))
- (def asdf (filter #(< 1 (first %)) asdf))
+(comment
+
+ ;; for use in repl
- (first asdf)
+ (ns beadgame.chainshot3)
+ (require 'beadgame.chainshot3)
+ (use 'criterium.core)
+ (use 'quil.core)
+
+
+ (build-visual-aid graph-atom)
+ (demo-genetic-algorithm)
+ (reset! graph-atom nil)
+
+ graph-atom
+ (reset! graph-atom test5)
)
+;; Greedy depth first search
+
+
+(defn greedy-depth-search
+ ([[graph cluster score]]
+ (loop [graph graph score score path []]
+ (let [children (remove #(zero? (% 2)) (find-all-clusters graph))]
+ (if (seq children)
+ (let [biggest-child (apply max-key #(% 2) children)]
+ (def b [children])
+ (recur (first biggest-child)
+ (+ score (biggest-child 2))
+ (conj path (first (second biggest-child)))))
+ [path score])))))
+
+
+
+(defn demonstrate-greedy-algorithm []
+ (doseq [graph-name ["test5" "test11"] :let [graph (read-file graph-name)]]
+ (let [[moves points] (greedy-depth-search [graph [] 0.0])]
+ (reset! graph-atom nil)
+ (println "Points: " points)
+ (reset! graph-atom graph)
+ (execute-moves graph moves graph-atom :time-delay 300))))
+
+(comment
+
+ (demonstrate-greedy-algorithm)
+
+ (use 'clojure.stacktrace)
+ (print-stack-trace *e 50)
+ (print-cause-trace *e 3)
+
+ )
+
-(defn getPossibleMoves
- "Returns a seq with delta pieces as well as the coordinatess forthe moves"
- [currentState]
- (let [startPieceCount (piecesLeft currentState)]
- (->>
- (for [x (range colLength) y (range rowLength)
- :let [nextState (chooseMove currentState x y)
- pointsGained (calculatePoints currentState nextState)]]
- [pointsGained x y])
- (filter #(pos? (first %)))))) ;only care about the moves which loose > 2 pieces because those are the only valid ones
-
-(defn playGame []
- "Would you like to play a game?"
- (println "Would you like to play a game?")
- (println "Specify the initial board file")
- (def currentState (readFile (read-line)))
- (def rowLength (count (currentState 0)))
- (def colLength (count currentState ))
- (def currentPoints 0)
- (def moveHistory [])
- (printRules)
- (while (keepPlaying currentState)
- (printBoard currentState)
- (println "Current Points" currentPoints)
- (try
- (let [ [x y] (map dec (read-string (str "[" (read-line) "]")) )
- nextState (chooseMove currentState x y) ]
- (println "The move was" (map inc [x y]))
- (def moveHistory (conj moveHistory (map inc [x y])))
- (def currentPoints (+ currentPoints (calculatePoints currentState nextState)))
- (if (< (piecesLeft nextState) (dec (piecesLeft currentState)))
- (def currentState nextState)))
- (catch Exception e (println "I'm sorry Dave, I'm afraid I can't do that"))))
-
- (printBoard currentState)
- (println "Your moves where" moveHistory)
- (cond
- (< 9000 currentPoints) (println "It's OVER 9000!!!!!!" currentPoints)
- :else (println "Game over! You failed with only" currentPoints "Points! Do you think your mom would be proud of that?"))
- (println "Play Again? (y/n)")
- (if (= "y" (read-line))
- (playGame)
- (println "Okay, I guess you weren't as cool as I thought you were...")))
-
-(defn -main [] (playGame))
+;(ns beadgame.breadth-search)
+
+;; Naive breadth-search algorithm, reallly long time
+(defn breadth-search
+ ([[graph cluster score]]
+ (if (> 0 score)
+ [0 '()]
+ (let [children (map breadth-search (find-all-clusters graph))]
+ (if (seq children)
+ (->
+ ;; Get the biggest value child
+ (apply max-key first children)
+ ((fn [[child-score path]] [ (+ child-score score) (conj path (first cluster) )])))
+ [0 '()])))))
+
+
+
+(defn guided-genetic []
+ (let [graph (prompt-graph)
+ [moves points]
+ (circle-of-life
+ graph
+ :population-count 50
+ :strand-length 150
+ :iteration-count 20
+ :selection-ratio 0.3)]
+
+ (println "Points: " points)
+ (reset! graph-atom nil)
+ (reset! graph-atom graph)
+ (execute-moves graph (filter-moves graph moves) graph-atom)))
+
+(defn guided-greedy []
+ (let [graph (prompt-graph)
+ [moves points] (greedy-depth-search [graph [] 0.0])]
+ (reset! graph-atom nil)
+ (println "Points: " points)
+ (reset! graph-atom graph)
+ (execute-moves graph moves graph-atom :time-delay 300)))
+
+(defn guided-breadth []
+ (let [graph (prompt-graph)
+ [points moves] (breadth-search [graph [] 1])]
+ (reset! graph-atom nil)
+ (println "Points: " points)
+ (reset! graph-atom graph)
+ (execute-moves graph moves graph-atom :time-delay 300)))
+
+(defn run-test-cases []
+ (println "This will run through all of the test cases provided" )
+ (println "First it will calculate the necessary moves")
+ (println "Then show them back to you at 1 move/s")
+ (println "It's recommeneded to view it on the opened beadgame window, prettier that way" )
+ (demo-genetic-algorithm))
+
+(defn guided-benchmark []
+ (let [graph (prompt-graph)]
+ (with-progress-reporting (bench (circle-of-life
+ graph
+ :population-count 50
+ :strand-length 150
+ :iteration-count 20
+ :selection-ratio 0.3)))))
+
+(time-body (Thread/sleep 1000))
+
+(defn main-menu []
+ (build-visual-aid graph-atom)
+ (println "A pretty format of the graph is being drawn as well as the console version")
+ (def stay-in (atom true))
+ (while @stay-in
+ (println "Choose an option:")
+ (println "\t (1) Play game normally")
+ (println "\t (2) Run genetic algorithms on board")
+ (println "\t (3) Run greedy-depth search on board")
+ (println "\t (4) Run breadth search on board (DANGER)")
+ (println "\t (5) Run test cases")
+ (println "\t (6) Benchmark the genetic-algorithm on a board")
+ (println "\t (7) Exit")
+ (condp = (read-line)
+ "1" (human-playing)
+ "2" (guided-genetic)
+ "3" (guided-greedy)
+ "4" (guided-breadth)
+ "5" (run-test-cases)
+ "6" (guided-benchmark)
+ "7" (reset! stay-in false)
+ (println "That's not an option"))))
+
+(defn -main [] (main-menu))
View
355 src/beadgame/chainshot2.clj
@@ -1,355 +0,0 @@
-(ns beadgame.chainshot2
- (:gen-class))
-
-
-
-
-(defmacro dbg[x] `(let [x# ~x] (println "dbg:" '~x "=" x#) x#))
-
-
-
-
-(defn read-file
- "Read the file starting board file"
- [filename]
- (let [filecontents (slurp filename)]
- (println "Reading file" filename)
- (map
- (fn [row] (clojure.string/split row #" "))
- (->
- filecontents
- (clojure.string/split #"\n")
- (reverse)))))
-
-
-
-
-(declare zip-graph)
-(declare conj-array)
-(declare read-graph)
-(declare conj-graph)
-(declare goto-neighbor)
-(declare print-board-from-root)
-
-(defn create-graph
- [parsed-file]
- (atom (map (fn [row] (map #(atom {:val %}) row)) parsed-file)))
-
-(defn connect-rows! [graph]
-
- (doseq [row @graph
- :let [rev-row (reverse row)]]
- (conj-array row :right)
- (conj-array rev-row :left)))
-
-(defn connect-cols! [graph]
- (for [x (range (dec (dbg (count @graph))))
- :let [ bottom-row (dbg (nth @graph x))
- top-row (nth @graph (inc x)) ]]
- (zip-graph bottom-row top-row)))
-
-(defn find-cluster
- "Finds clusters starting from a specific node, clusters are connected nodes with the same value."
- ([graph starting-node]
- (find-cluster graph starting-node (@starting-node :val) ))
- ([graph starting-node value ]
- (let [
- right-node (goto-neighbor starting-node :right)]
- (println (@starting-node :val))
- (if (and
- (= (@starting-node :val) value)
- (not (nil? starting-node)))
- (->> [starting-node]
- (apply conj (dbg (find-cluster graph right-node value))))
- []))))
-
-(defn get-node-path
- "goes through the nodes using direction until it hits an end, returns it as a map
- Specify the starting position and the update function to update the position"
-
- ([root-node direction position position-update]
- (get-node-path root-node direction position position-update (fn [a] a) {}))
-
- ([root-node direction position position-update board-map]
- (loop [position position
- current-node root-node
- board-map board-map]
- (if (nil? current-node)
- board-map
- (recur
- (position-update position)
- (goto-neighbor current-node direction)
- (assoc board-map position current-node ))))))
-
-(goto-neighbor (get-root-node graph) :down)
-
-(defn move-node-down!
- "Moves a node down a slot, by splicing the bottom nodes left and right neighbors to the top node's"
- [node-to-move]
- ;; Check to see if there is a node above this one to move
- (if-not (nil? (goto-neighbor node-to-move :up))
- (move-node-down! (goto-neighbor node-to-move :up)))
-
- (let [right-node (-> node-to-move
- (goto-neighbor :down)
- (goto-neighbor :right))
- left-node (-> node-to-move
- (goto-neighbor :down)
- (goto-neighbor :left))]
- ;;atach the right node to the current node and vice versa
- (conj-graph :right node-to-move right-node)
- (conj-graph :left right-node node-to-move)
-
- (conj-graph :left node-to-move left-node)
- (conj-graph :right left-node node-to-move)))
-
-
-
-(defn remove-node!
- "Function to remove a node and handle the change in other nodes
- It will first move the top node down, then splice the top nodes and the removee node's bottom together
- If it is removed and there is no top or bottom node then we splice the adjacent columns together"
- [removee-node]
- ;; There is something above this node so we need to bring it down
- (move-node-down! (goto-neighbor removee-node :up))
-
- (if (and (nil? (goto-neighbor removee-node :up)) (nil? (goto-neighbor removee-node :down)))
- ;;No bottom or top nodes, we need to splice the adjacent columns together
- nil
- ;; Else we need to splice the top and bottom together
- (let [ top-node (goto-neighbor removee-node :up)
- bottom-node (goto-neighbor removee-node :down)]
- (conj-graph :up bottom-node top-node)
- (conj-graph :down top-node bottom-node))))
-
-
-
-(defn print-board-from-root
- [root-node]
-
- (let [root-row (get-node-path
- root-node
- :right
- [0 0]
- #(update-in % [0] inc))
- full-board-map ( map (fn [[pos atm]]
- (get-node-path
- atm
- :up
- pos
- #(update-in % [1] inc)))
- root-row)
- asdf (def temp-col2 full-board-map)
- formatted-rows (for [y (reverse (range (count @graph)))]
- (map
- (fn [a] (if (nil? a) " " (@a :val)))
- ( map (apply merge full-board-map) (for [x (range (count @graph))] [x y]))))]
- (doseq [row formatted-rows] (println row))))
-
-(( get-node-path
- ((get-node-path
- root
- :right
- [0 0]
- #(update-in % [0] inc)) [2 0])
- :up
- [2 0]
- #(update-in % [1] inc)) [2 1])
-
-(def root (get-root-node graph))
-(nth asdf 2)
-
-(doseq [cols temp-col2]
- (doseq [[pos item] cols]
- (print " " pos " "))
- (println))
-
-(second (first (first temp-col2)))
-
-(def temp-col (get-node-path
- (traverse-graph root :x 3 :y 1)
- :up
- [ 0 0 ]
- #(update-in % [0] inc)))
-
-(swap! ((nth temp-col2 2) [2 1]) #(assoc % :val "x"))
-(map (fn [[pos a]] (@a :val)) temp-col)
-
-(remove-node! (traverse-graph root :x 3 :y 2))
-(->
- (traverse-graph root :x 3 :y 1)
- (goto-neighbor :left)
- (goto-neighbor :up)
- (goto-neighbor :right))
-(print-board-from-root root)
-
- ( goto-neighbor (traverse-graph root :x 2 :y 5) :right)
-
-(comment
- (require 'beadgame.chainshot2)
- (ns beadgame.chainshot2)
-(print-graph graph)
-(def cls (find-cluster graph (get-root-node graph)))
- (map (fn [a] (@a :val)) cls)
-
-(conj-graph :right root-node other-node2)
-
-conj-graph
-
-(def graph (create-graph (read-file "startBoard")))
- graph
-(connect-cols! graph)
-(connect-rows! graph)
-
- (for [x (range (dec (dbg (count @graph))))
- :let [ bottom-row (nth @graph x)
- top-row (nth @graph (inc x)) ]]
- (zip-graph bottom-row top-row))
-
- (print-graph graph)
-
-(def rnode (goto-neighbor (get-root-node graph) :right))
- (@((@(get-root-node graph) :up)) :val)
- (@(trampoline @(get-root-node graph) :up) :val)
- (@(goto-neighbor (get-root-node graph) :up) :up)
-
- (@(-> root
- (goto-neighbor :right)
- (goto-neighbor :right)
- (goto-neighbor :up))
- :val)
-
- (@(-> (get-root-node graph)
- (goto-neighbor :right)
- (goto-neighbor :right)
- (goto-neighbor :up)
- (goto-neighbor :up)
- (goto-neighbor :right))
- :val)
-
- (@(get-root-node graph) :val)
-
-(@(get-root-node graph) :up)
-
- (let [value "g"
- starting-node (goto-neighbor (get-root-node graph) :right 3)
- right-node (goto-neighbor starting-node :right)]
- (if (and
- (= (dbg (@starting-node :val)) value)
- (not (nil? starting-node)))
- (->> [starting-node]
- (apply conj (find-cluster graph right-node value)))
- []))
-
- (zip-graph
- (second @graph)
- (nth @graph 3))
-
-(@(traverse-graph graph :x 2 :y 3) :val)
-
-(goto-neighbor (get-root-node graph) :down)
-(find-cluster nil \g)
-
-(@(goto-neighbor (first (first @graph)) :right 1) :val)
-
-(@(@(@(first (first @graph)) :up) :down) :val)
-
-(@(traverse-graph graph :x 2 :y 1) :val)
-
-(traverse-graph graph :x 1 :y 3)
- )
-
-
-
-(defn get-root-node [graph]
- (first (first @graph)))
-
-
-(defn goto-neighbor
- ([parent-node direction]
- (trampoline @parent-node direction))
- ([parent-node direction times]
- (loop [parent-node parent-node times times]
- (if (pos? times)
- (recur (trampoline @parent-node direction) (dec times))
- parent-node))))
-
-
-(defn traverse-graph
- [root-node & position]
- (let [{:keys [x y]} position]
- (->
- root-node
- (goto-neighbor :right (dec x))
- (goto-neighbor :up (dec y)))))
-
-
-
-
-
-
-
-(comment
- )
-
-(defn print-graph
- ([graph]
- (let [ graph (read-graph graph)
- [first-row & rest-rows] graph]
- (print-graph first-row rest-rows)))
- ([first-row rest-rows]
- (if (seq rest-rows)
- (print-graph (first rest-rows) (rest rest-rows)))
- (println first-row)))
-
-(nil? (get-root-node graph))
-
-(defn read-graph
- "Prints the cyclic graph"
- [graph]
- (map
- (fn [row] (map
- (fn [node] (:val @node))
- row))
- @graph))
-
-
-
-(defn zip-graph
- [root-row upper-row]
- "Joins two rows by top and bottom"
- (println "zipping up!")
- (for [x (range (count root-row))
- :let [bottom-node (nth root-row x)
- top-node (nth upper-row x)]]
- (do
- (conj-graph :up bottom-node top-node)
- (conj-graph :down top-node bottom-node)
- nil)))
-
-
-
-
-(defn conj-array
- "Connects an array of nodes together through left and right"
- [elements direction]
- (loop [elements elements]
- (if (seq (rest elements))
- (let [first-element (first elements)
- second-element (second elements)
- rest-elements (rest elements)]
- (conj-graph direction first-element second-element)
- (recur
- rest-elements ))))
- nil)
-
-(defn conj-graph
- "Connects two nodes, the parents to the child.
- If there is alread a node on the parents right it will be recursively placed
- Specify the direction as in :up"
-
- [direction parent child]
- (swap! parent #(assoc % direction (fn[] child)))
- parent)
-
-
View
679 src/beadgame/chainshot3.clj
@@ -1,679 +0,0 @@
-;; So here is the third iteration that involves no state to operate
-;; Although we are going to have a single unit of state to make the game playaple it isn't required
-;; and in fact not used for the AI algorithms
-
-(ns beadgame.chainshot3
- (:use [criterium.core]
- [quil.core])
- (:gen-class))
-
-(defmacro dbg[x] `(let [x# ~x] (println "dbg:" '~x "=" x#) x#))
-
-
-;; Simple atom to keep state.
-(def graph-atom (atom nil))
-
-(comment
- (def sample-graph ^{:bound-limit 5} {
- 4 { 0 "g" 1 "g" 2 "r" 3 "r" 4 "g" }
- 3 { 0 "g" 1 "g" 2 "r" 3 "r" 4 "g" }
- 2 { 0 "g" 1 "g" 2 "b" 3 "r" 4 "g" }
- 1 { 0 "r" 1 "g" 2 "g" 3 "r" 4 "g" }
- 0 { 0 "r" 1 "g" 2 "g" 3 "r" 4 "r" }})
-
- (def sample-pos ^"Position is [x y]" [0 4])
- (comment "First part pertains to the col no* and the second part pertains to row number")
- (= (get-in sample-graph sample-pos) "r")
- (print-graph sample-graph)
-
- (def bound-limit (:bound-limit (meta sample-graph) ))
-
- (reduce #(and %1 %2) (map pos? [0 1]))
- (ns beadgame.chainshot3)
-
- )
-
-(comment
- (def test8 (print-graph (read-file "testBoard8")))
- (def test5 (print-graph (read-file "test5")))
- bound-limit
- )
-
-(defn read-file
- "Reads a file and outputs a graph, also sets the global bound limit"
- [filename]
- (->
- (slurp filename)
- (clojure.string/split #"\n")
- (count)
- (#(def bound-limit %)))
-
- ( loop [ characters (->
- (slurp filename)
- (clojure.string/split #"\s"))
- graph (apply merge {} (for [x (range bound-limit)] [x {}]))
- positions (for [y (reverse (range bound-limit)) x (range bound-limit) ] [x y])]
- (if (seq characters)
- (recur
- (rest characters)
- (assoc-in graph (first positions) (first characters))
- (rest positions))
- graph)))
-
-
-(defn bounded? [bound-limit position]
- "Returns the position if it is within the 0 < position < bound-limit
- Else returns false"
- (if (->>
- position
- (map #(and (<= 0%) (< % bound-limit)) )
- (reduce #(and %1 %2)))
- position
- false))
-
-(defn goto-neighbor-with-limit
- [bound-limit position direction]
- (if-let[ new-position (bounded?
- bound-limit
- (condp = direction
- :up (update-in position [0] inc)
- :down (update-in position [0] dec)
- :left (update-in position [1] dec)
- :right (update-in position [1] inc)))]
- new-position
- nil))
-
-
-(defn goto-neighbor
- [graph position direction]
- (goto-neighbor-with-limit bound-limit position direction))
-
-(defn read-neighbor
- [graph position direction]
- (get-in graph (goto-neighbor graph position direction)))
-
-(defn pieces-left [graph]
- (->>
- (vals graph)
- (map vals)
- (map count)
- (reduce +)))
-
-(defn find-cluster
- ([graph position]
- (let [value (get-in graph position)
- cluster (first (find-cluster graph position value [] []))]
- (if (< 2 (count cluster))
- cluster
- [])))
-
- ([graph position value cluster visited]
- (let [ directions [:up :down :left :right]
- neighbors (map #(goto-neighbor graph position % ) directions)]
- (if (and
- (not (nil? position))
- (not (nil? value))
- (= value (get-in graph position))
- (not (some #{position} visited)))
- ;(conj (map #(find-cluster graph % value (conj visited position)) neighbors) position)
- (->>
- [(conj cluster position) (conj visited position) ]
- (apply find-cluster graph (nth neighbors 0) value)
- (apply find-cluster graph (nth neighbors 1) value)
- (apply find-cluster graph (nth neighbors 2) value)
- (apply find-cluster graph (nth neighbors 3) value))
-
-
- [cluster (conj visited position)]))))
-
-
-(defn shift-graph-changes
- [graph nodes]
- ; Get the cols that have changed
- (let [changed-cols (map first nodes)]
- [(loop [graph graph changed-cols changed-cols]
- (if (seq changed-cols)
- (recur
- (->>
- (get graph (first changed-cols))
- (#(remove nil? (map % (range bound-limit))))
- (zipmap (range bound-limit))
- (assoc graph (first changed-cols)))
- (rest changed-cols))
- graph))
- nodes]))
-
-(defn shift-graph-cols
- [graph nodes]
- [(->>
- (for [row (range bound-limit)] (graph row))
- (remove empty?)
- (zipmap (range bound-limit)))
- nodes])
-
-
-
-(defn remove-nodes
- ([graph nodes]
- [(loop [graph graph nodes nodes]
- (if (seq nodes)
- (recur
- (assoc-in graph (first nodes) nil)
- (rest nodes))
- graph))
- nodes]))
-
-(map #(print " " %) (range bound-limit))
-
-(defn print-graph
- ([graph]
- ;;print the top row first and work your way down
- (doseq [y (reverse (range bound-limit)) x (range bound-limit) :let [node (get-in graph [x y])] ]
- (if (zero? x) (do (println) (print (inc y))))
- (print " " (if (nil? node) " " node)))
- (println)
- (print " ")
- (doseq [ x (range bound-limit) ] (print " " (inc x)))
- (println)
- graph)
- ([graph & more]
- (print-graph graph)
- ;; Echo back original args for chaining purposes
- (conj more graph)))
-
-(defn calculate-points
- [cluster]
- (if (> (count cluster) 2)
- (Math/pow (- (count cluster) 2) 2)
- 0.0))
-
-(defn choose-move
- [graph cluster]
- [ (->>
- [graph cluster]
- (apply remove-nodes)
- (apply shift-graph-changes)
- (apply shift-graph-cols)
- ((fn [[graph nodes]] graph)))
- (calculate-points cluster)])
-
-
-
-(defn find-all-clusters
- [graph]
- (loop [ possible-moves (for [x (range bound-limit) y (range bound-limit)] [x y])
- cluster-positions #{}
- clusters []
- graphs []
- points [] ]
- (cond
- (nil? (seq possible-moves)) (map vector graphs clusters points)
- (nil? (get-in graph (first possible-moves)))
- (recur
- (rest possible-moves)
- (conj cluster-positions (first possible-moves))
- clusters
- graphs
- points)
- (nil? (cluster-positions (first possible-moves)))
- ;; We haven't added this position as part of a previous cluster
- (let [new-cluster (find-cluster graph (first possible-moves))
- move (choose-move graph new-cluster)
- new-graph (first move)
- new-points (second move)]
- (def c new-cluster)
- ;;check to see if the new-cluster is invalid
- (if (nil? (seq new-cluster))
- (recur
- (rest possible-moves)
- cluster-positions
- clusters
- graphs
- points)
- (recur
- (rest possible-moves)
- (apply conj cluster-positions new-cluster) ;; Add the cluster to our set of visited nodes
- (conj clusters new-cluster)
- (conj graphs new-graph)
- (conj points new-points))))
- :else (recur
- (rest possible-moves)
- cluster-positions
- clusters
- graphs
- points))))
-
-(defn execute-moves
- "Simple way to view moves being executed"
- [graph moves graph-atom & {:keys [time-delay] :or {time-delay 1000}}]
- (loop [moves moves graph graph points 0]
- (Thread/sleep time-delay)
- (if (seq moves)
- (let [new-cluster (find-cluster graph (first moves))
- move (choose-move graph new-cluster)
- new-graph (first move)
- new-points (second move)]
- (print-graph new-graph)
- (reset! graph-atom new-graph)
- (println "Points: " (+ new-points points))
- (recur
- (rest moves)
- new-graph
- (+ points new-points)))
- nil)))
-
-(defn filter-moves
- "If a move doesn't do anything we can filter it out
- Useful for outputting the final set of moves"
- [graph moves]
- (loop [graph graph moves moves filtered-moves []]
- (if (seq moves)
- (let [new-cluster (find-cluster graph (first moves))
- move (choose-move graph new-cluster)
- new-graph (first move)]
- (if (seq new-cluster)
- ;; We have a valid move
- (recur new-graph (rest moves) (conj filtered-moves (first new-cluster)))
- ;; We don't have a valid move
- (recur graph (rest moves) filtered-moves)))
- filtered-moves)))
-
-(defn input-position-bounded? [[x y]]
- (if (bounded? bound-limit [x y])
- [x y]
- (do (println "Sorry the position is out of the range") nil)))
-
-(defn input-valid? [graph [x y]]
- (if (get-in graph [x y])
- [x y]
- (do (println "sorry there is nothing there" nil))))
-
-(defn cluster-valid? [graph [x y]]
- (if (seq (find-cluster graph [x y]))
- [x y]
- (do (println "The cluster is too small") nil)))
-
-(defn valid-move? [graph position]
- (and (input-position-bounded? position)
- (input-valid? graph position)
- (cluster-valid? graph position)))
-
-(defn prompt-move [graph]
- (println "Pick your move x y")
- (let [position (map dec (map read-string (clojure.string/split (read-line) #" ")))]
- (println position)
- (if (valid-move? graph position)
- (vec position)
- (prompt-move graph))))
-
-(defn prompt-graph []
- (println "Type in the board-file")
- (read-file (read-line)))
-
-(defn finished-game [points]
- (println "Congrats you finished the game with: " points "points!"))
-
-(declare prompt-play-again)
-
-(defn human-playing []
- (loop [graph (prompt-graph) points 0]
- (print-graph graph)
- (println "Points: " points)
- (reset! graph-atom graph)
- (let [move-position (prompt-move graph)
- cluster (find-cluster graph move-position)
- [new-graph new-points] (choose-move graph cluster)]
- (if (seq (find-all-clusters new-graph))
- (recur new-graph (+ points new-points))
- (do (finished-game (+ points new-points)) (prompt-play-again))))))
-
-(defn prompt-play-again []
- (println "Play Again (y/n)")
- (condp = (read-line)
- "y" (do (println "playing again!") (human-playing))
- "n" (println "not playing again!")
- (do (println "Please choose either y or n") (prompt-play-again))))
-
-
-(comment
- test5
- (reset! graph-atom test5)
- (build-visual-aid graph-atom)
- (prompt-graph)
- (human-playing)
- (breadth-search [sample-graph [] 1])
-
- )
-
-
-
-;; Genetic algorithms
-
-(defn initialize
- "Returns randomly generated points that will be used to pick clusters
- Lets call it a strand"
- [length]
- (repeatedly length (fn [] [(rand-int bound-limit) (rand-int bound-limit)])))
-
-(defn generate-strands
- [strand-count strand-length]
- (take strand-count ( repeatedly #( initialize strand-length ))))
-
-(defn fitness
- "calculates the fitness of strand"
- [graph strand]
- (loop [strand strand graph graph points 0]
- (if (seq strand)
- (let [move (->>
- (find-cluster graph (first strand))
- (choose-move graph))
- new-graph (first move)
- points (+ points (second move))]
- (recur
- (rest strand)
- new-graph
- points))
- points)))
-
-
-(defn crossover
- [strand1 strand2]
- (apply conj
- (vec (take (rand-int (count strand1)) strand1))
- (take (inc (rand-int (dec (count strand2)))) strand2)))
-
-(defn simple-mutate
- [strand]
- (if (< 0.70 (rand))
- (initialize 1)
- strand))
-
-(defn roulette-wheel-selection
- [strands fitness-values times]
- (let [strands (map vector strands fitness-values)
- sorted-strands (sort-by #(* -1 (second %)) strands)
- sum (reduce + fitness-values)
- normalized-strands (map #(vector (first %) (/ (second %) sum)) sorted-strands)
- accumulated-strands (loop [normalized-strands normalized-strands accumulated-strands [] running-sum 0]
- (if (seq normalized-strands)
- (recur
- (rest normalized-strands)
- (conj accumulated-strands (update-in (first normalized-strands) [1] #(+ running-sum %)))
- (+ running-sum (second (first normalized-strands)) ))
- accumulated-strands))]
- (take times (repeatedly #(first (filter (fn [strand] (let [r (rand)] (> (second strand) r))) accumulated-strands))))))
-
-(defn breed-strands
- [strands children-count]
- (take children-count (repeatedly #(-> (crossover (rand-nth strands) (rand-nth strands))
- (simple-mutate)))))
-
-
-(defn circle-of-life
- "Function that composes all the parts of the genetic algorithm
-
- population-count - How many different strands should exist
- strand-length - How long each strand should be ( a strand is a set of moves
- iteration-count - How many iterations to go through
- selection-ratio - Select what percentage of the initial population for future use
-
- "
-
- [graph & {:keys [population-count strand-length iteration-count selection-ratio]
- :or {population-count 100 strand-length 20 iteration-count 20 selection-ratio 0.1 }}]
- (let [initial-population ( generate-strands population-count strand-length)]
- (loop [population initial-population iteration iteration-count max-strand [[] 0]]
- (println "iteration" iteration)
- (if (pos? iteration)
- (let [fitness-values (pmap (partial fitness graph) population)
- new-population (-> (map first (roulette-wheel-selection population fitness-values (int (* population-count selection-ratio))))
- (breed-strands population-count))
- new-max-strand (apply max-key second (map vector population fitness-values))]
- (println "Fitness so far:" (take 5 fitness-values))
- (recur new-population (dec iteration) (max-key second new-max-strand max-strand)))
- max-strand))))
-
-
-
-(defn build-visual-aid [graph-atom]
-
- (defn setup []
- (smooth)
- (frame-rate 10)
- (background 200))
-
- (def color-map (zipmap (map str (map char (range 65 91) ))
- (repeatedly #(map (fn [a] (rand-int 256)) (range 3)))))
- (def color-map (assoc color-map nil '(200)))
-
- (defn draw []
- (stroke 200)
- (stroke-weight 10)
- (fill (random 255))
- (if (nil? @graph-atom)
- (background 200)
-
- (let [graph @graph-atom diam (/ 800 bound-limit)]
- (doseq [y (reverse (range bound-limit)) x (range bound-limit) :let [ [plot-x plot-y] (map #(+ (/ 800 bound-limit 2) (* (/ 800 bound-limit) %)) [x y])
- node (get-in graph [x y])] ]
- (apply fill (color-map node))
- (ellipse plot-x (- 800 plot-y) diam diam) ))))
-
-
- (defsketch example ;;Define a new sketch named example
- :title "Beadgame!" ;;Set the title of the sketch
- :setup setup ;;Specify the setup fn
- :draw draw ;;Specify the draw fn
- :size [800 800]))
-
-
-
-(defn demo-genetic-algorithm []
-
- (doseq [graph-name [
- "test-boards/test1"
- "test-boards/test2"
- "test-boards/test3"
- "test-boards/test4"
- "test-boards/test5"
- "test-boards/test6"
- "test-boards/test7"
- "test-boards/test8"
- "test-boards/test9"
- "test-boards/test10"
- "test-boards/test11"]
- :let [graph (read-file graph-name)]]
- (println "Testing" graph-name)
- (let [[time-dur [moves points]]
- (time-body
- (circle-of-life
- graph
- :population-count 50
- :strand-length 150
- :iteration-count 20
- :selection-ratio 0.3))]
-
-
- (reset! graph-atom nil)
- (reset! graph-atom graph)
-
- (execute-moves graph (filter-moves graph moves) graph-atom :time-delay 10)
- (println "Points: " points)
- (println "Time: " time-dur)
- (println "Pieces left: " (pieces-left @graph-atom)))))
-
-
-
-
-
-
-(comment
-
- ;;clear the board if we are showing it
- (reset! graph-atom nil)
-
- (println "Testing test 11")
- (def test11 (print-graph (read-file "test11")))
- (def moves (circle-of-life test11 :population-count 50 :strand-length 50 :iteration-count 20 :selection-ratio 0.8))
- (println "Points for test 11" (second moves))
- (reset! graph-atom test11)
- (execute-moves test11 (filter-moves test11 (first moves)) graph-atom :time-delay 300)
-
- )
-
-
-(defn benchmark-genetic-algorithm []
- (println "Benchmarking test 11")
- (def test5 (print-graph (read-file "test5")))
- (with-progress-reporting (bench
- (circle-of-life test5 100 40 20 0.3)))
-
- (println "Benchmarking test 5")
- (def test11 (print-graph (read-file "test11")))
- (with-progress-reporting (bench
- (circle-of-life test11 100 40 20 0.3))))
-
-(comment
-
- ;; for use in repl
-
- (ns beadgame.chainshot3)
- (require 'beadgame.chainshot3)
- (use 'criterium.core)
- (use 'quil.core)
-
-
- (build-visual-aid graph-atom)
- (demo-genetic-algorithm)
- (reset! graph-atom nil)
-
- graph-atom
- (reset! graph-atom test5)
-
- )
-;; Greedy depth first search
-
-
-(defn greedy-depth-search
- ([[graph cluster score]]
- (loop [graph graph score score path []]
- (let [children (remove #(zero? (% 2)) (find-all-clusters graph))]
- (if (seq children)
- (let [biggest-child (apply max-key #(% 2) children)]
- (def b [children])
- (recur (first biggest-child)
- (+ score (biggest-child 2))
- (conj path (first (second biggest-child)))))
- [path score])))))
-
-
-
-(defn demonstrate-greedy-algorithm []
- (doseq [graph-name ["test5" "test11"] :let [graph (read-file graph-name)]]
- (let [[moves points] (greedy-depth-search [graph [] 0.0])]
- (reset! graph-atom nil)
- (println "Points: " points)
- (reset! graph-atom graph)
- (execute-moves graph moves graph-atom :time-delay 300))))
-
-(comment
-
- (demonstrate-greedy-algorithm)
-
- (use 'clojure.stacktrace)
- (print-stack-trace *e 50)
- (print-cause-trace *e 3)
-
- )
-
-
-;(ns beadgame.breadth-search)
-
-;; Naive breadth-search algorithm, reallly long time
-(defn breadth-search
- ([[graph cluster score]]
- (if (> 0 score)
- [0 '()]
- (let [children (map breadth-search (find-all-clusters graph))]
- (if (seq children)
- (->
- ;; Get the biggest value child
- (apply max-key first children)
- ((fn [[child-score path]] [ (+ child-score score) (conj path (first cluster) )])))
- [0 '()])))))
-
-
-
-(defn guided-genetic []
- (let [graph (prompt-graph)
- [moves points]
- (circle-of-life
- graph
- :population-count 50
- :strand-length 150
- :iteration-count 20
- :selection-ratio 0.3)]
-
- (println "Points: " points)
- (reset! graph-atom nil)
- (reset! graph-atom graph)
- (execute-moves graph (filter-moves graph moves) graph-atom)))
-
-(defn guided-greedy []
- (let [graph (prompt-graph)
- [moves points] (greedy-depth-search [graph [] 0.0])]
- (reset! graph-atom nil)
- (println "Points: " points)
- (reset! graph-atom graph)
- (execute-moves graph moves graph-atom :time-delay 300)))
-
-(defn guided-breadth []
- (let [graph (prompt-graph)
- [points moves] (breadth-search [graph [] 1])]
- (reset! graph-atom nil)
- (println "Points: " points)
- (reset! graph-atom graph)
- (execute-moves graph moves graph-atom :time-delay 300)))
-
-(defn run-test-cases []
- (println "This will run through all of the test cases provided" )
- (println "First it will calculate the necessary moves")
- (println "Then show them back to you at 1 move/s")
- (println "It's recommeneded to view it on the opened beadgame window, prettier that way" )
- (demo-genetic-algorithm))
-
-(defn guided-benchmark []
- (let [graph (prompt-graph)]
- (with-progress-reporting (bench (circle-of-life
- graph
- :population-count 50
- :strand-length 150
- :iteration-count 20
- :selection-ratio 0.3)))))
-
-(time-body (Thread/sleep 1000))
-
-(defn main-menu []
- (build-visual-aid graph-atom)
- (println "A pretty format of the graph is being drawn as well as the console version")
- (def stay-in (atom true))
- (while @stay-in
- (println "Choose an option:")
- (println "\t (1) Play game normally")
- (println "\t (2) Run genetic algorithms on board")
- (println "\t (3) Run greedy-depth search on board")
- (println "\t (4) Run breadth search on board (DANGER)")
- (println "\t (5) Run test cases")
- (println "\t (6) Benchmark the genetic-algorithm on a board")
- (println "\t (7) Exit")
- (condp = (read-line)
- "1" (human-playing)
- "2" (guided-genetic)
- "3" (guided-greedy)
- "4" (guided-breadth)
- "5" (run-test-cases)
- "6" (guided-benchmark)
- "7" (reset! stay-in false)
- (println "That's not an option"))))
-
-(defn -main [] (main-menu))
View
10 src/beadgame/helloworld.clj
@@ -1,10 +0,0 @@
-(ns beadgame.helloworld
- (:gen-class))
-(defn -main
- []
- (println "starting!!")
- (while true
- (let [ x (read-line)]
- (println " hello World! " x))))
-
-
View
BIN  target/beadgame-3.0-standalone.jar
Binary file not shown
View
BIN  target/beadgame-3.0.jar
Binary file not shown

No commit comments for this range

Something went wrong with that request. Please try again.