HomeAboutCodePastes
aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordieggsy <dieggsy@pm.me>2021-04-24 11:18:22 -0400
committerdieggsy <dieggsy@pm.me>2021-04-24 11:18:22 -0400
commita3749e0a466f0a761c2fe1855cf9c70d279ee282 (patch)
tree7c26ea2fd0166b088bd9fcea806578685b8f7aa6
parent9e604028882441afdf2c7b158d75e87a899e28b6 (diff)
downloadproject-euler-a3749e0a466f0a761c2fe1855cf9c70d279ee282.tar.gz
Add some SBCL solutions
-rw-r--r--sbcl/numbers.lisp70
-rwxr-xr-xsbcl/p01.lisp11
-rwxr-xr-xsbcl/p02.lisp28
-rwxr-xr-xsbcl/p03.lisp9
-rwxr-xr-xsbcl/p04.lisp43
-rwxr-xr-xsbcl/p05.lisp6
-rwxr-xr-xsbcl/p31.lisp30
-rwxr-xr-xsbcl/p44.lisp30
8 files changed, 227 insertions, 0 deletions
diff --git a/sbcl/numbers.lisp b/sbcl/numbers.lisp
new file mode 100644
index 0000000..dc12a5a
--- /dev/null
+++ b/sbcl/numbers.lisp
@@ -0,0 +1,70 @@
+(defpackage :numbers
+ (:use :cl)
+ (:export factor miller-rabin primep))
+
+(in-package :numbers)
+
+(declaim (optimize (speed 3) (space 0) (debug 0)))
+
+;; from rosetta code
+(defun factor (n &optional (acc '()))
+ (when (> n 1)
+ (loop with max-d = (isqrt n)
+ for d = 2 then (if (evenp d) (1+ d) (+ d 2)) do
+ (cond ((> d max-d)
+ (return (cons (list n 1) acc)))
+ ((zerop (rem n d))
+ (return (factor (truncate n d)
+ (if (eq d (caar acc))
+ (cons
+ (list (caar acc) (1+ (cadar acc)))
+ (cdr acc))
+ (cons (list d 1) acc)))))))))
+
+;; Miller Rabin (rosetta code)
+(defun factor-out (number divisor)
+ "Return two values R and E such that NUMBER = DIVISOR^E * R,
+ and R is not divisible by DIVISOR."
+ (do ((e 0 (1+ e))
+ (r number (/ r divisor)))
+ ((/= (mod r divisor) 0) (values r e))))
+
+(defun mult-mod (x y modulus) (mod (* x y) modulus))
+
+(defun expt-mod (base exponent modulus)
+ "Fast modular exponentiation by repeated squaring."
+ (labels ((expt-mod-iter (b e p)
+ (cond ((= e 0) p)
+ ((evenp e)
+ (expt-mod-iter (mult-mod b b modulus)
+ (/ e 2)
+ p))
+ (t
+ (expt-mod-iter b
+ (1- e)
+ (mult-mod b p modulus))))))
+ (expt-mod-iter base exponent 1)))
+
+(defun random-in-range (lower upper)
+ "Return a random integer from the range [lower..upper]."
+ (+ lower (random (+ (- upper lower) 1))))
+
+(defun miller-rabin (n k)
+ "Test N for primality by performing the Miller-Rabin test K times.
+ Return NIL if N is composite, and T if N is probably prime."
+ (cond ((= n 1) nil)
+ ((< n 4) t)
+ ((evenp n) nil)
+ (t
+ (multiple-value-bind (d s) (factor-out (- n 1) 2)
+ (labels ((strong-liar? (a)
+ (let ((x (expt-mod a d n)))
+ (or (= x 1)
+ (loop repeat s
+ for y = x then (mult-mod y y n)
+ thereis (= y (- n 1)))))))
+ (loop repeat k
+ always (strong-liar? (random-in-range 2 (- n 2)))))))))
+
+(defun primep (n)
+ (miller-rabin n 12))
diff --git a/sbcl/p01.lisp b/sbcl/p01.lisp
new file mode 100755
index 0000000..82f719d
--- /dev/null
+++ b/sbcl/p01.lisp
@@ -0,0 +1,11 @@
+#!/usr/bin/sbcl --script
+
+(defun p01 ()
+ (labels ((arithmetic-sum (first last n)
+ (* n (/ (+ first last) 2))))
+ (let ((max 999))
+ (+ (arithmetic-sum 3 (* 3 (floor max 3)) (floor max 3))
+ (arithmetic-sum 5 (* 5 (floor max 5)) (floor max 5))
+ (- (arithmetic-sum 15 (* 15 (floor max 15)) (floor max 15)))))))
+
+(time (prin1 (p01)))
diff --git a/sbcl/p02.lisp b/sbcl/p02.lisp
new file mode 100755
index 0000000..ba9b284
--- /dev/null
+++ b/sbcl/p02.lisp
@@ -0,0 +1,28 @@
+#!/usr/bin/sbcl --script
+
+
+;; Scheme translation
+(defun scheme ()
+ (labels ((lp (i j res)
+ (if (> j 4000000)
+ res
+ (lp j (+ i j) (if (evenp j) (+ res j) res)))))
+ (lp 1 2 0)))
+
+;; Using loop
+(defun cl ()
+ (loop :for i = 1 :then j
+ :and j = 2 :then (+ i j)
+ :until (>= j 4000000)
+ :if (evenp j)
+ :sum j))
+
+
+
+(format t "Scheme translation:~%")
+(time (princ (scheme)))
+
+(format t "Idiomatic:~%")
+(time (princ (cl)))
+
+;; (loop for i = 1 then j #.(read) j = 2 then (+ i j) repeat 10 collect (list i j))
diff --git a/sbcl/p03.lisp b/sbcl/p03.lisp
new file mode 100755
index 0000000..ada0179
--- /dev/null
+++ b/sbcl/p03.lisp
@@ -0,0 +1,9 @@
+#!/usr/bin/sbcl --script
+(load "numbers")
+
+(use-package :numbers)
+
+(defun p03 ()
+ (apply #'max (mapcar #'car (factor 600851475143))))
+
+(time (princ (p03)))
diff --git a/sbcl/p04.lisp b/sbcl/p04.lisp
new file mode 100755
index 0000000..e8782c5
--- /dev/null
+++ b/sbcl/p04.lisp
@@ -0,0 +1,43 @@
+#!/usr/bin/sbcl --script
+
+(declaim (optimize (speed 3) (space 0) (debug 0)))
+
+;; Let's emulate named loop
+(defmacro nlet (name binds &rest body)
+ `(labels ((,name ,(mapcar #'car binds) ,@body))
+ (,name ,@(mapcar #'cadr binds))))
+
+(defun palindromep (int)
+ (let ((str (write-to-string int)))
+ (string= str (reverse str))))
+
+
+(defun scheme ()
+ (nlet lp ((i 900)
+ (res 0))
+ (nlet loop1 ((j i)
+ (res res))
+ (let ((prod (* i j)))
+ (cond
+ ((> i 999)
+ res)
+ ((> j 999)
+ (lp (+ i 1) res))
+ ((and (palindromep prod)
+ (> prod res))
+ (loop1 (+ j 1) prod))
+ (t (loop1 (+ j 1) res)))))))
+
+(defun cl ()
+ (loop :for i :from 900 :to 999
+ :maximize (loop :for j :from 900 :to 999
+ :and prod = (* i j)
+ :if (palindromep prod)
+ :return prod
+ :finally (return 0))))
+
+(format t "Scheme translation:~%")
+(time (prin1 (scheme)))
+
+(format t "Idiomatic:~%")
+(time (prin1 (cl)))
diff --git a/sbcl/p05.lisp b/sbcl/p05.lisp
new file mode 100755
index 0000000..01d2253
--- /dev/null
+++ b/sbcl/p05.lisp
@@ -0,0 +1,6 @@
+#!/usr/bin/sbcl --script
+
+(defun p05 ()
+ (apply #'lcm (loop for x from 1 to 20 collect x)))
+
+(time (princ (p05)))
diff --git a/sbcl/p31.lisp b/sbcl/p31.lisp
new file mode 100755
index 0000000..ed92fb0
--- /dev/null
+++ b/sbcl/p31.lisp
@@ -0,0 +1,30 @@
+#!/usr/bin/sbcl --script
+
+(defun recursive ()
+ (labels ((coin-combinations (amount coins)
+ (let ((coin (car coins)))
+ (cond ((not coin) 0)
+ ((= amount 0) 1)
+ ((> coin amount) (coin-combinations amount (cdr coins)))
+ (t
+ (+ (coin-combinations (- amount (car coins))
+ coins)
+ (coin-combinations amount (cdr coins))))))))
+ (let ((coins '(200 100 50 20 10 5 2 1)))
+ (coin-combinations 200 coins))))
+
+;; (defun iterative ()
+;; (labels ((coin-combinations (amount coins count)
+;; (let ((coin (car coins)))
+;; (cond ((not coin) 0)
+;; ((= amount 0) 1)
+;; ((> coin amount) (coin-combinations amount (cdr coins)))
+;; (t
+;; (+ (coin-combinations (- amount (car coins))
+;; coins)
+;; (coin-combinations amount (cdr coins))))))))
+;; (let ((coins '(200 100 50 20 10 5 2 1)))
+;; (coin-combinations 200 coins))))
+
+(format t "Recursive:")
+(time (princ (recursive)))
diff --git a/sbcl/p44.lisp b/sbcl/p44.lisp
new file mode 100755
index 0000000..9fb29d1
--- /dev/null
+++ b/sbcl/p44.lisp
@@ -0,0 +1,30 @@
+#!/usr/bin/sbcl --script
+
+(defun pentagonal (n)
+ (/ (* n (- (* 3 n) 1))
+ 2))
+
+(defun pentagonalp (n)
+ (zerop
+ (mod (/ (+ (sqrt (- 1 (* 4 3 (* 2 (- n))))) 1) (* 2 3))
+ 1)))
+
+(defparameter +pent+
+ (loop :for n = 1 :then (1+ n)
+ :until (= n 10000)
+ :collect (pentagonal n)))
+
+
+(defun p44 ()
+ (loop :for i :in +pent+
+ :minimize
+ (loop :for j :in +pent+
+ :until (>= j i)
+ :as diff = (- i j)
+ :if (and (pentagonalp (+ i j))
+ (pentagonalp diff))
+ :return diff
+ :finally
+ (return #.double-float-positive-infinity))))
+
+(time (princ (p44)))