Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

We’re showing branches in this repository, but 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
11 README.md
View
@@ -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
2  project.clj
View
@@ -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 )
796 src/beadgame/chainshot.clj
View
@@ -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))
355 src/beadgame/chainshot2.clj
View
@@ -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)
-
-
679 src/beadgame/chainshot3.clj
View
@@ -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))
10 src/beadgame/helloworld.clj
View
@@ -1,10 +0,0 @@
-(ns beadgame.helloworld
- (:gen-class))
-(defn -main
- []
- (println "starting!!")
- (while true
- (let [ x (read-line)]
- (println " hello World! " x))))
-
-
BIN  target/beadgame-3.0-standalone.jar
View
Binary file not shown
BIN  target/beadgame-3.0.jar
View
Binary file not shown

No commit comments for this range

Something went wrong with that request. Please try again.