Skip to content

Instantly share code, notes, and snippets.

@jonsmock

jonsmock/fox-goose-beans.clj

Last active July 4, 2017 14:00
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save jonsmock/3e4abf488bfcc064f33373a3d090e027 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save jonsmock/3e4abf488bfcc064f33373a3d090e027 to your computer and use it in GitHub Desktop.
Download ZIP
Puzzle solutions in core.logic
Raw
fox-goose-beans.clj
;; https://en.wikipedia.org/wiki/Fox,_goose_and_bag_of_beans_puzzle
(ns fun.puzzle1
(:require [clojure.core.logic :as l]))
(defn pick-one [el rst col]
(l/conde
[(l/conso el rst col)]
[(l/fresh [not-taken maybe-taken rst-not-taken]
(l/conso not-taken maybe-taken col)
(l/conso not-taken rst-not-taken rst)
(pick-one el rst-not-taken maybe-taken))]))
(defn lasto [steps step]
(l/conde
[(l/== steps [step])]
[(l/fresh [el rst]
(l/conso el rst steps)
(lasto rst step))]))
; Assumes farmer is not there
(defn nothing-eaten [side]
(l/conde
[(l/== side [])]
[(l/fresh [a]
(l/== side [a]))]
[(l/== side [:fox :beans])]
[(l/== side [:beans :fox])]))
(defn all-safe [step]
(l/fresh [farmer left right]
(l/== step [farmer left right])
(l/conde
[(l/== farmer :left)
(nothing-eaten right)]
[(l/== farmer :right)
(nothing-eaten left)])))
(defn transport [prev-step next-step]
(l/fresh [item farmer1 farmer2 left1 left2 right1 right2]
(l/== prev-step [farmer1 left1 right1])
(l/== next-step [farmer2 left2 right2])
(all-safe prev-step)
(all-safe next-step)
(l/conde
; Move item from left to right
[(l/== farmer1 :left)
(l/== farmer2 :right)
(l/conso item right1 right2)
(pick-one item left2 left1)]
; Move item from right to left
[(l/== farmer1 :right)
(l/== farmer2 :left)
(l/conso item left1 left2)
(pick-one item right2 right1)]
; Farmer returns without an item (forgot this case originally!)
[(l/== farmer1 :right)
(l/== farmer2 :left)
(l/== left1 left2)
(l/== right1 right2)]
[(l/== farmer1 :left)
(l/== farmer2 :right)
(l/== left1 left2)
(l/== right1 right2)])))
(defn transportations [steps]
(l/fresh [a b _rst rst]
(l/conde
[(l/== steps [a])]
[(transport a b)
(l/conso a rst steps)
(l/conso b _rst rst)
(transportations rst)])))
(comment
(first
(l/run 1 [steps]
(l/fresh [a b c d e f g h]
(l/== steps [a b c d e f g h])
(l/== a [:left [:fox :goose :beans] []])
(l/fresh [ff gg bb]
(l/== h [:right [] [ff gg bb]])) ; Can't hard code order of stuff at end
(transport a b)
(transport b c)
(transport c d)
(transport d e)
(transport e f)
(transport f g)
(transport g h))))
(first
(l/run 1 [steps]
(l/fresh [ff gg bb]
(l/firsto steps [:left [:fox :goose :beans] []])
(lasto steps [:right [] [ff gg bb]])
(transportations steps)
)))
)
Raw
missionary-cannibal.clj
; https://en.wikipedia.org/wiki/Missionaries_and_cannibals_problem
(ns fun.puzzle2
(:require [clojure.core.logic :as l]))
;; List manipulation
(defn lasto [col el]
(l/conde
[(l/== col [el])]
[(l/fresh [other rst]
(l/conso other rst col)
(lasto rst el))]))
(defn steps
"Each element of col must satisfy g with its neighboring elements."
[g col]
(l/fresh [a b _rst rst]
(l/conde
[(l/== col [])]
[(l/== col [a])]
[(g a b)
(l/conso a rst col)
(l/conso b _rst rst)
(steps g rst)])))
;; Problem helpers
(defn missionary [person]
(l/== person :m))
(defn cannibal [person]
(l/== person :c))
(defn emptyo [side]
(l/== side [[] []]))
(defn fullo [side]
(l/== side [[:m :m :m] [:c :c :c]]))
(defn add-person [person before after]
(l/fresh [m1 m2 c1 c2]
(l/== before [m1 c1])
(l/== after [m2 c2])
(l/conde
[(missionary person)
(l/conso person m1 m2)
(l/== c1 c2)]
[(cannibal person)
(l/== m1 m2)
(l/conso person c1 c2)])))
(defn more-or-equal-to [xs ys]
(l/conde
[(l/== ys [])]
[(l/fresh [x y xs' ys']
(l/conso x xs' xs)
(l/conso y ys' ys)
(more-or-equal-to xs' ys'))]))
;; I think this is introducing too many streams
;; hmmm
;; Yes it definitely is, see below version doesn't
(defn everyone-safe [side]
(l/fresh [ms cs]
(l/== side [ms cs])
(l/conde
[(l/== ms [])]
[(more-or-equal-to ms cs)])))
(defn everyone-safe [side]
(l/conde
[(l/== side [[] [:c :c :c]])]
[(l/== side [[] [:c :c]])]
[(l/== side [[] [:c]])]
[(l/== side [[] []])]
[(l/== side [[:m] []])]
[(l/== side [[:m] [:c]])]
[(l/== side [[:m :m] [:c]])]
[(l/== side [[:m :m] [:c :c]])]
[(l/== side [[:m :m :m] [:c :c]])]
[(l/== side [[:m :m :m] [:c :c :c]])]))
(defn transport* [prev-step next-step]
(l/fresh [left1 left2 right1 right2]
(l/== prev-step [:left left1 right1])
(l/== next-step [:right left2 right2])
(everyone-safe left1)
(everyone-safe left2)
(everyone-safe right1)
(everyone-safe right2)
(l/conde
; 1 person across
[(l/fresh [person]
(add-person person right1 right2)
(add-person person left2 left1))]
; 2 people across
[(l/fresh [person1 person2 intl intr]
(add-person person1 right1 intr)
(add-person person2 intr right2)
(add-person person1 intl left1)
(add-person person2 left2 intl))])))
(defn transport [prev-step next-step]
(l/conde
[(transport* prev-step next-step)]
[(transport* next-step prev-step)]))
(comment
(l/run 1 [q]
(l/fresh [everyone noone]
(fullo everyone)
(emptyo noone)
(l/firsto q [:left everyone noone])
(lasto q [:right noone everyone])
(steps transport q)))
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment