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