annotate src/clojureDemo/project_euler.clj @ 1:6d9bdaf919f7

added clojureDemo source
author Robert McIntyre <rlm@mit.edu>
date Fri, 20 Aug 2010 00:32:44 -0400
parents
children
rev   line source
rlm@1 1
rlm@1 2 (ns clojureDemo.project-euler
rlm@1 3
rlm@1 4 (:refer-clojure :exclude [+ - / *
rlm@1 5 assoc conj dissoc empty get into seq
rlm@1 6 = < > <= >= zero?
rlm@1 7 ])
rlm@1 8
rlm@1 9 (:use [clojure.contrib.generic
rlm@1 10 arithmetic
rlm@1 11 collection
rlm@1 12 comparison
rlm@1 13 ])
rlm@1 14
rlm@1 15 (:use [clojure.contrib
rlm@1 16 combinatorics
rlm@1 17 repl-utils
rlm@1 18 def
rlm@1 19 duck-streams
rlm@1 20 shell-out
rlm@1 21 import-static
rlm@1 22 lazy-seqs
rlm@1 23 logging
rlm@1 24 map-utils
rlm@1 25 math
rlm@1 26 mock
rlm@1 27 monads
rlm@1 28 ns-utils
rlm@1 29 seq-utils
rlm@1 30 function-utils
rlm@1 31 profile
rlm@1 32 str-utils
rlm@1 33 ])
rlm@1 34
rlm@1 35 (:use [clojure.contrib.pprint :exclude [write]])
rlm@1 36
rlm@1 37 (:use [clojure.contrib.pprint.examples
rlm@1 38 hexdump
rlm@1 39 json
rlm@1 40 multiply
rlm@1 41 props
rlm@1 42 show-doc
rlm@1 43 xml
rlm@1 44 ])
rlm@1 45
rlm@1 46 (:import java.io.File)
rlm@1 47 (:import [java.util Calendar Date])
rlm@1 48
rlm@1 49 )
rlm@1 50
rlm@1 51
rlm@1 52
rlm@1 53
rlm@1 54
rlm@1 55 (defn range-sum
rlm@1 56 "calculates the sum of a range. Takes the exact same arguments
rlm@1 57 as clojure.core/range equilivent to (reduce + (range start end step)), but O(1)."
rlm@1 58 ([end]
rlm@1 59 (/ (* end (- end 1) ) 2))
rlm@1 60
rlm@1 61 ([start end]
rlm@1 62 (- (range-sum end) (range-sum start)))
rlm@1 63
rlm@1 64 ([start end step]
rlm@1 65 (letfn [(zero-sum [end step] (* step (range-sum 0 (ceil (/ end step)))))]
rlm@1 66 (+ (zero-sum (- end start) step) (* start (int (/ (- end start) step)))))))
rlm@1 67
rlm@1 68
rlm@1 69
rlm@1 70 (defn range-sum-squares
rlm@1 71 "equivalent to (reduce + (map #(expt % 2) (range start end step))),
rlm@1 72 but runs in O(1) time."
rlm@1 73 ([end]
rlm@1 74 (let [n (- end 1)]
rlm@1 75 (- (* (expt n 3) 1/3) ;continous volume
rlm@1 76 (+ (* -1/6 n) (* -1/2 (expt n 2)))))) ;discrete correction
rlm@1 77
rlm@1 78 ([start end]
rlm@1 79 (- (range-sum-squares end) (range-sum-squares start)))
rlm@1 80
rlm@1 81 ([start end step]
rlm@1 82 ;; (letfn [(zero-sum-squares [end step]
rlm@1 83 ;; (* step step (range-sum-squares 0 (ceil (/ end step)))))]
rlm@1 84 ;; (+
rlm@1 85 ;; (* 2 step (range-sum (ceil (/ (- end start) step))))
rlm@1 86 ;; (zero-sum end step)
rlm@1 87 ;; (* start start (int (/ (- end start) step)))))))
rlm@1 88 ))
rlm@1 89
rlm@1 90
rlm@1 91 (defn prime-factors
rlm@1 92 "all the prime factors of the number n"
rlm@1 93 [n]
rlm@1 94 (filter #(= 0 (rem n %)) (for [p primes :while (<= p n)] p)))
rlm@1 95
rlm@1 96 (defn factor? [a b] (= 0 (rem a b)))
rlm@1 97
rlm@1 98 (defn factor-map [a b]
rlm@1 99 (if (factor? a b)
rlm@1 100 {b (quot a b)}
rlm@1 101 nil))
rlm@1 102
rlm@1 103
rlm@1 104 (defn divides? [numerator divisor] (= (rem numerator divisor) 0))
rlm@1 105
rlm@1 106
rlm@1 107 (def != (comp not =))
rlm@1 108
rlm@1 109
rlm@1 110 (defn decompose [number factor]
rlm@1 111 (loop [n number counter 0]
rlm@1 112 (if (!= (rem n factor) 0)
rlm@1 113 counter
rlm@1 114 (recur (/ n factor) (inc counter)))))
rlm@1 115
rlm@1 116
rlm@1 117
rlm@1 118
rlm@1 119
rlm@1 120
rlm@1 121
rlm@1 122 (defn single-factor [{num :current-num index :prime-index factors :prime-factors :as old-state}]
rlm@1 123 (let [divisor (nth primes index)
rlm@1 124 new-index (inc index)
rlm@1 125 done? (= num 1)]
rlm@1 126 (if (divides? num divisor)
rlm@1 127 (let [new-num (/ num (expt divisor (decompose num divisor)))
rlm@1 128 factors (assoc factors divisor (decompose num divisor))]
rlm@1 129 [[factors done?] (assoc old-state
rlm@1 130 :current-num new-num :prime-index new-index :prime-factors factors)])
rlm@1 131
rlm@1 132 [[factors done?] (assoc old-state
rlm@1 133 :current-num num :prime-index new-index :prime-factors factors)])))
rlm@1 134
rlm@1 135
rlm@1 136 (defn wtf "a is not used" [a] (domonad state-m [part single-factor] part))
rlm@1 137
rlm@1 138 (defn fuck-it []
rlm@1 139 (domonad state-m
rlm@1 140 [[factors done?]
rlm@1 141 (state-m-until second wtf nil)]
rlm@1 142
rlm@1 143 factors))
rlm@1 144
rlm@1 145 (defn prime-factor-map [num]
rlm@1 146
rlm@1 147 (first ((fuck-it) {:prime-factors {}
rlm@1 148 :prime-index 0
rlm@1 149 :current-num num})))
rlm@1 150
rlm@1 151 (defn prime-factors-monad [num]
rlm@1 152 (sort (keys (prime-factor-map num))))
rlm@1 153
rlm@1 154
rlm@1 155
rlm@1 156
rlm@1 157
rlm@1 158
rlm@1 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@1 160 ;; fun with state monad
rlm@1 161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
rlm@1 162
rlm@1 163
rlm@1 164 (defn ++ [{num :num :as world}]
rlm@1 165 (let [num++ (inc num)]
rlm@1 166 [num++ (assoc world :num num++)]))
rlm@1 167
rlm@1 168 (defn huh? []
rlm@1 169 (with-monad state-m
rlm@1 170 (domonad [x ++
rlm@1 171 y ++]
rlm@1 172 y)))
rlm@1 173
rlm@1 174
rlm@1 175 (comment
rlm@1 176
rlm@1 177 huh?
rlm@1 178 ->
rlm@1 179 ((let [m-bind (fn m-bind-state [mv f]
rlm@1 180 (fn [s]
rlm@1 181 (let [[v ss] (mv s)]
rlm@1 182 ((f v) ss))))]
rlm@1 183 (m-bind
rlm@1 184 ++ (fn [x] ++))) {:num 1})
rlm@1 185
rlm@1 186
rlm@1 187 )
rlm@1 188
rlm@1 189
rlm@1 190 (defn wordify [n] (cl-format nil "~R" n))
rlm@1 191
rlm@1 192 (defn british-letter-count-prof [n]
rlm@1 193 (prof :total
rlm@1 194 (let [and? (prof :rem-test (if (and (> n 99) (!= 0 (rem n 100))) 3 0))
rlm@1 195 word (prof :wordify (wordify n))
rlm@1 196 word-seq (prof :sequence (seq word))
rlm@1 197 word-filter (prof :filter (filter #(Character/isLetter %) word-seq))
rlm@1 198 word-count (prof :count (count word-filter))
rlm@1 199 answer (prof :add (+ and? word-count))]
rlm@1 200 answer)))
rlm@1 201
rlm@1 202 (defn british-letter-count-prof2
rlm@1 203 "now this is faster, because it uses string manipulation. go profiling!"
rlm@1 204 [n]
rlm@1 205 (prof :total
rlm@1 206 (let [and? (prof :rem-test (if (and (> n 99) (!= 0 (rem n 100))) 3 0))
rlm@1 207 word (prof :wordify (wordify n))
rlm@1 208 word-regex (prof :regex (re-gsub #"[\W-,]" "" word))
rlm@1 209
rlm@1 210 word-count (prof :count (.length word-regex))
rlm@1 211 answer (prof :add (+ and? word-count))]
rlm@1 212 answer)))
rlm@1 213
rlm@1 214
rlm@1 215
rlm@1 216
rlm@1 217
rlm@1 218
rlm@1 219
rlm@1 220
rlm@1 221
rlm@1 222
rlm@1 223
rlm@1 224
rlm@1 225
rlm@1 226
rlm@1 227
rlm@1 228
rlm@1 229
rlm@1 230
rlm@1 231
rlm@1 232 ;pseudo code for primes
rlm@1 233
rlm@1 234 ;fn prime-decomposition
rlm@1 235 ; [n]
rlm@1 236 ; map = {}
rlm@1 237 ;
rlm@1 238 ; for x in primes
rlm@1 239 ; add to map (divide teh fick out n x)
rlm@1 240 ; n = n / prime-factors
rlm@1 241 ; if n == 1 BREAK;
rlm@1 242 ;
rlm@1 243 ;
rlm@1 244
rlm@1 245
rlm@1 246
rlm@1 247 (defn rng [seed]
rlm@1 248 (let [m 259200
rlm@1 249 value (/ (float seed) (float m))
rlm@1 250 next (rem (+ 54773 (* 7141 seed)) m)]
rlm@1 251 [value next]))
rlm@1 252
rlm@1 253
rlm@1 254 (defn yeah! []
rlm@1 255 (let [name sequence-m
rlm@1 256 m-bind (:m-bind name)
rlm@1 257 m-result (:m-result name)
rlm@1 258 m-zero (:m-zero name)
rlm@1 259 m-plus (:m-plus name)]
rlm@1 260
rlm@1 261
rlm@1 262 (m-bind (range 5) (fn [a] (m-bind [2 3] (fn [b] (m-result (+ a b))))))))
rlm@1 263
rlm@1 264
rlm@1 265 (defn ohhhh!! []
rlm@1 266
rlm@1 267 (let
rlm@1 268 [name state-m
rlm@1 269 m-bind (:m-bind name)
rlm@1 270 m-result (:m-result name) ]
rlm@1 271
rlm@1 272 (m-bind rng (fn [x1] (m-bind rng (fn [x2] (m-result (+ x1 x2))))))))
rlm@1 273
rlm@1 274
rlm@1 275
rlm@1 276 (defmulti palindrome? class)
rlm@1 277
rlm@1 278 (defmethod palindrome? (class "string") [a]
rlm@1 279 (= (seq a) (reverse a)))
rlm@1 280
rlm@1 281 (defmethod palindrome? (class 500) [a]
rlm@1 282 (palindrome? (str a)))
rlm@1 283
rlm@1 284
rlm@1 285
rlm@1 286
rlm@1 287
rlm@1 288
rlm@1 289
rlm@1 290
rlm@1 291 (defn circulars
rlm@1 292 "returns a vector of all the circular permutations of a number"
rlm@1 293 [n]
rlm@1 294 (map #(Integer. (apply str %)) (rotations (seq (str n)))))
rlm@1 295
rlm@1 296
rlm@1 297 (defn prime-factors
rlm@1 298 [n]
rlm@1 299 (for [a primes :while (<= a n) :when (= (rem n a) 0)] a))
rlm@1 300
rlm@1 301
rlm@1 302 (defmethod = [nil java.lang.Integer] [ a b ]
rlm@1 303 false)
rlm@1 304
rlm@1 305
rlm@1 306
rlm@1 307 (def mil 1000000)
rlm@1 308 (def bil 1000000000)
rlm@1 309
rlm@1 310 (defn primes-under-million [] (apply hash-set (take 78498 primes)))
rlm@1 311 (def primes-under-million (memoize primes-under-million))
rlm@1 312
rlm@1 313
rlm@1 314 (defn primes-under-billion [] (apply hash-set (take 664579 primes)))
rlm@1 315 (def primes-under-billion (memoize primes-under-billion))
rlm@1 316
rlm@1 317
rlm@1 318
rlm@1 319
rlm@1 320
rlm@1 321 (defn prime? [n] (not (nil? (get (primes-under-billion) n))))
rlm@1 322
rlm@1 323
rlm@1 324 (defn circular-memoize
rlm@1 325 "assumes that f is a predicate that takes in a number for which,
rlm@1 326 if the predicate is true for the number, it is also true for all
rlm@1 327 of the circular permutations of the number. Memoizes the result
rlm@1 328 for all circular permutations so as to avoid subsequent computation."
rlm@1 329 [f]
rlm@1 330 (let [mem (atom {})]
rlm@1 331 (fn [n]
rlm@1 332 (if-let [e (find @mem n)]
rlm@1 333 (val e)
rlm@1 334 (let [ret (f n)]
rlm@1 335 (dorun (for [circ (circulars n)]
rlm@1 336 (swap! mem assoc n ret)))
rlm@1 337 ret)))))
rlm@1 338
rlm@1 339 (defn circularly-prime?
rlm@1 340 [n]
rlm@1 341 (not (some (comp not prime?) (circulars n))))
rlm@1 342
rlm@1 343 (def circularly-prime? (memoize circularly-prime?))
rlm@1 344
rlm@1 345
rlm@1 346 (defmethod = :default [& args]
rlm@1 347 (apply clojure.core/= args))
rlm@1 348
rlm@1 349 (def logins
rlm@1 350 (map str
rlm@1 351 [319 680 180 690 129 620 762 689 762 318
rlm@1 352 368 710 720 710 629 168 160 689 716 731
rlm@1 353 736 729 316 729 729 710 769 290 719 680
rlm@1 354 318 389 162 289 162 718 729 319 790 680
rlm@1 355 890 362 319 760 316 729 380 319 728 716]))
rlm@1 356
rlm@1 357 (defn remove-multiples [n]
rlm@1 358 (reduce (fn [a b] (if (= (last a) b) a (conj a b))) [] n))
rlm@1 359
rlm@1 360 (defn insert [item n vect]
rlm@1 361 (let [split (split-at n vect)]
rlm@1 362 (apply vector (flatten [(first split) item (last split)]))))
rlm@1 363
rlm@1 364 (defn expand-code [old-code [c b a]]
rlm@1 365 (let [main-length (count old-code)]
rlm@1 366 (for [x (range (inc main-length)) y (range (inc x)) z (range (inc y))]
rlm@1 367 (insert c z (insert b y (insert a x old-code))))))
rlm@1 368
rlm@1 369 (defn domain-expand-contract [old-domain constraint]
rlm@1 370 (let [new-domain
rlm@1 371 (map remove-multiples
rlm@1 372 (remove-multiples
rlm@1 373 (sort
rlm@1 374 (apply concat
rlm@1 375 (map #(expand-code % constraint) old-domain)))))
rlm@1 376 min-code-length (apply min (map count new-domain)) ]
rlm@1 377 (map #(apply str %) (filter #(= (count %) min-code-length) new-domain))))
rlm@1 378 (def domain-expand-contract (memoize domain-expand-contract))
rlm@1 379
rlm@1 380
rlm@1 381
rlm@1 382 (defn lazy-fibo
rlm@1 383 ([] (concat [0 1] (lazy-fibo 0 1)))
rlm@1 384 ([a b] (let [n (+ a b)] (lazy-seq (cons n (lazy-fibo b n))))))
rlm@1 385
rlm@1 386
rlm@1 387 (defn collatz-seq [n]
rlm@1 388 (lazy-seq
rlm@1 389 (cond (= n 1) [1]
rlm@1 390 (even? n) (lazy-seq (cons n (collatz-seq (/ n 2))))
rlm@1 391 (odd? n) (lazy-seq (cons n (collatz-seq (+ 1 (* 3 n))))))))
rlm@1 392 (def collatz-seq (memoize collatz-seq))
rlm@1 393
rlm@1 394
rlm@1 395
rlm@1 396 (defn pythagorean-triple? [a b c]
rlm@1 397 (let [[a b c] (sort [a b c])]
rlm@1 398 (= (+ (* a a) (* b b) ) (* c c))))
rlm@1 399
rlm@1 400
rlm@1 401 (defn sum-squares [coll]
rlm@1 402 (reduce + (map #(* % %) coll)))
rlm@1 403
rlm@1 404
rlm@1 405 (defn british-letter-count [n]
rlm@1 406
rlm@1 407 (let [and? (if (and (> n 99) (!= 0 (rem n 100))) 3 0)]
rlm@1 408
rlm@1 409 (+ and? (count (filter #(Character/isLetter %) (seq (wordify n)))))))
rlm@1 410
rlm@1 411
rlm@1 412
rlm@1 413 (defmacro apply-macro
rlm@1 414 "This is evil. Don't ever use it. It makes a macro behave like a
rlm@1 415 function. Seriously, how messed up is that?
rlm@1 416
rlm@1 417 Evaluates all args, then uses them as arguments to the macro as with
rlm@1 418 apply.
rlm@1 419
rlm@1 420 (def things [true true false])
rlm@1 421 (apply-macro and things)
rlm@1 422 ;; Expands to: (and true true false)"
rlm@1 423 [macro & args]
rlm@1 424 (cons macro (flatten (map eval args))))
rlm@1 425
rlm@1 426 (defn fun1 [] (Thread/sleep 5000) 5)
rlm@1 427
rlm@1 428 (defn fun2 [] (Thread/sleep 30000) 5)
rlm@1 429
rlm@1 430
rlm@1 431 (def naturals (iterate inc 0))
rlm@1 432
rlm@1 433
rlm@1 434
rlm@1 435
rlm@1 436 (defn race []
rlm@1 437 (let [result (ref nil)
rlm@1 438 threads [(Thread. (fn [] (try
rlm@1 439 (let [answer (fun1)]
rlm@1 440 (dosync (ref-set result answer)))
rlm@1 441 (catch Exception _ nil))))
rlm@1 442 (Thread. (fn [] (try
rlm@1 443 (let [answer (fun2)]
rlm@1 444 (dosync (ref-set result answer)))
rlm@1 445 (catch Exception _ nil))))]]
rlm@1 446
rlm@1 447 (dorun (map #(.start %) threads))
rlm@1 448 (loop []
rlm@1 449 (if (!= (deref result) nil)
rlm@1 450 (do (dorun (map #(.stop %) threads))
rlm@1 451 (deref result))
rlm@1 452 (recur)))))
rlm@1 453
rlm@1 454
rlm@1 455
rlm@1 456
rlm@1 457
rlm@1 458
rlm@1 459
rlm@1 460 (defn make-date [year month day] (do (let [date (Calendar/getInstance)] (.set date year month day 0 0) date)))
rlm@1 461
rlm@1 462 (def jan-1-1901 (make-date 1900 0 1))
rlm@1 463
rlm@1 464 (defn sunday? [#^java.util.Date date] (re-matches #"^Sun.*" (str date)))
rlm@1 465
rlm@1 466 (count (filter sunday? (for [a (range 1 40000) date [(.getTime (make-date 1900 0 a)) ] :while (< (.getYear date) 100)] date )))
rlm@1 467
rlm@1 468
rlm@1 469
rlm@1 470
rlm@1 471 (comment
rlm@1 472
rlm@1 473 ;; ----------------------------------------------------------------------
rlm@1 474 ;; Answers
rlm@1 475 ;; ----------------------------------------------------------------------
rlm@1 476
rlm@1 477 ; Problem 1
rlm@1 478 (+ (range-sum 0 1001 3) (range-sum 0 1001 5) (* -1 (range-sum 0 1001 15)))
rlm@1 479
rlm@1 480 ; Problem 2
rlm@1 481 (reduce + (for [a (filter even? (fibs)) :while (<= a 4000000 )] a))
rlm@1 482
rlm@1 483 ; Problem 3
rlm@1 484 (apply max (prime-factors 600851475143))
rlm@1 485
rlm@1 486 ; Problem 4
rlm@1 487 (reduce max (for [a (range 100 1000) b (range 100 1000) :when (palindrome? (* a b))] (* a b)))
rlm@1 488
rlm@1 489 ; Problem 5
rlm@1 490 (reduce lcm (range 1 21))
rlm@1 491
rlm@1 492 ; Problem 6
rlm@1 493 (- (expt (range-sum 101) 2) (range-sum-squares 101))
rlm@1 494
rlm@1 495 ; Problem 7
rlm@1 496 (nth primes 10000)
rlm@1 497
rlm@1 498
rlm@1 499 ; Problem 9
rlm@1 500 (reduce * (first (for [a (range 1 1000) b (range 1 a) c [(sqrt (sum-squares [a b]))]
rlm@1 501 :when (= (+ a b c) 1000)] [a b c])))
rlm@1 502
rlm@1 503 ; Problem 10
rlm@1 504 (reduce + (for [a primes :while (< a 2000000)] a))
rlm@1 505
rlm@1 506
rlm@1 507
rlm@1 508
rlm@1 509
rlm@1 510 ; Problem 14
rlm@1 511 (first (reduce (fn [a b] (if (> (count a) (count b)) a b)) [] (map collatz-seq (range 1 mil))))
rlm@1 512
rlm@1 513
rlm@1 514 ; Problem 16
rlm@1 515 (reduce + (map #(Character/getNumericValue %) (seq (str (expt 2 1000)))))
rlm@1 516
rlm@1 517 ; Problem 17
rlm@1 518 (reduce + (map british-letter-count (range 1 1001)))
rlm@1 519
rlm@1 520
rlm@1 521 ; Problem 24
rlm@1 522 (nth (lex-permutations [ 0 1 2 3 4 5 6 7 8 9]) (- mil 1))
rlm@1 523
rlm@1 524 ; Problem 33
rlm@1 525 (reduce * (for [num (range 1 10)
rlm@1 526 den (range 1 10)
rlm@1 527 weird (range 1 10)
rlm@1 528 top [(+ num (* 10 weird))]
rlm@1 529 bottom [(+ weird (* 10 den))]
rlm@1 530 :when (and (> (/ top bottom) 1) (= (/ top bottom) (/ num den)))]
rlm@1 531 (/ bottom top)))
rlm@1 532
rlm@1 533 ; Problem 35
rlm@1 534 (count (filter circularly-prime? (primes-under-million)))
rlm@1 535
rlm@1 536 ; Problem 40
rlm@1 537 (let [fff (apply str (take 1030000 naturals))]
rlm@1 538 (reduce * (map #(Character/getNumericValue (nth fff %))
rlm@1 539 (map (fn [x] (expt 10 x)) (range 7)) )))
rlm@1 540
rlm@1 541
rlm@1 542
rlm@1 543
rlm@1 544
rlm@1 545
rlm@1 546 ; Problem 79
rlm@1 547 (reduce domain-expand-contract [""] logins)
rlm@1 548
rlm@1 549 )
rlm@1 550
rlm@1 551
rlm@1 552
rlm@1 553
rlm@1 554
rlm@1 555
rlm@1 556
rlm@1 557
rlm@1 558
rlm@1 559