# HG changeset patch # User Steve Losh # Date 1511911178 18000 # Node ID acbb1860ce620e0cc214fb48bf13f6e4d5f0db61 # Parent 0b59f0204222571878f94f75e93c08cedb98ed12 Add janky infix-math macro diff -r 0b59f0204222 -r acbb1860ce62 euler.asd --- a/euler.asd Sat Nov 04 12:47:10 2017 -0400 +++ b/euler.asd Tue Nov 28 18:19:38 2017 -0500 @@ -27,6 +27,7 @@ (:file "package") (:module "src" :serial t :components ((:file "primes") + (:file "math") (:file "utils") (:file "hungarian") (:file "problems") diff -r 0b59f0204222 -r acbb1860ce62 src/math.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/math.lisp Tue Nov 28 18:19:38 2017 -0500 @@ -0,0 +1,102 @@ +(in-package :euler) + +;;;; Operator Protocol +(defgeneric operatorp (object) + (:method ((object t)) nil)) + +(defun operandp (object) + (not (operatorp object))) + +(defgeneric operator-arity (operator)) +(defgeneric operator-function (operator)) +(defgeneric operator-weight (operator)) + +(defmacro define-operator (symbol function arity weight) + `(progn + (defmethod operatorp ((symbol (eql ',symbol))) + t) + (defmethod operator-arity ((symbol (eql ',symbol))) + ,arity) + (defmethod operator-function ((symbol (eql ',symbol))) + ,function) + (defmethod operator-weight ((symbol (eql ',symbol))) + ,weight))) + + +;;;; Binary +(define-operator = '= 2 0) +(define-operator < '> 2 0) +(define-operator > '< 2 0) +(define-operator <= '>= 2 0) +(define-operator >= '<= 2 0) +(define-operator - '- 2 1) +(define-operator + '+ 2 1) +(define-operator * '* 2 2) +(define-operator / '/ 2 2) +(define-operator % 'rem 2 2) +(define-operator ^ 'expt 2 3) + + +;;;; Unary +(define-operator sqrt 'sqrt 1 10) +(define-operator sin 'sin 1 10) +(define-operator cos 'cos 1 10) +(define-operator tan 'tan 1 10) +(define-operator abs 'abs 1 10) + + +;;;; Parsing +(defun shunting-yard (tokens &aux operators output) + (labels ((precedence>= (a b) + (unless (null a) + (>= (operator-weight a) + (operator-weight b)))) + (pop-unary-operator () + (push (list (operator-function (pop operators)) + (pop output)) + output)) + (pop-binary-operator () + (push (list (operator-function (pop operators)) + (pop output) + (pop output)) + output)) + (pop-operator () + (ecase (operator-arity (first operators)) + (1 (pop-unary-operator)) + (2 (pop-binary-operator)))) + (lisp-expression-p (expr) + (or (vectorp expr) + (and (consp expr) + (eq (first expr) 'lisp)))) + (lisp-expression (expr) + (etypecase expr + (vector (coerce expr 'list)) + (cons (second expr))))) + (do* ((tokens (reverse tokens) (rest tokens)) + (prev nil token) + (token (first tokens) (first tokens))) + ((null tokens)) + (cond + ((lisp-expression-p token) + (push (lisp-expression token) output)) + ((consp token) + (push (shunting-yard token) output)) + ((operatorp token) + (iterate (while (precedence>= (first operators) + token)) + (pop-operator) + (finally (push token operators)))) + ((and prev (not (operatorp prev))) ; implicit multiplication + (setf token prev) + (push '* tokens) + (push prev tokens)) + (t (push token output)))) + (iterate (while operators) + (pop-operator))) + (first output)) + + +;;;; API +(defmacro math (&rest expr) + (shunting-yard expr)) + diff -r 0b59f0204222 -r acbb1860ce62 src/problems.lisp --- a/src/problems.lisp Sat Nov 04 12:47:10 2017 -0400 +++ b/src/problems.lisp Tue Nov 28 18:19:38 2017 -0500 @@ -599,7 +599,8 @@ ;; starting with n=0. (flet ((primes-produced (a b) (iterate (for n :from 0) - (while (primep (+ (square n) (* a n) b))) + (while (primep + (math n ^ 2 + a n + b))) (counting t)))) (iterate (for-nested ((a :from -999 :to 999) (b :from -1000 :to 1000))) @@ -787,8 +788,7 @@ (labels ((rotate (n distance) (multiple-value-bind (hi lo) (truncate n (expt 10 distance)) - (+ (* (expt 10 (digits-length hi)) lo) - hi))) + (math lo * 10 ^ #(digits-length hi) + hi))) (rotations (n) (mapcar (curry #'rotate n) (range 1 (digits-length n)))) (circular-prime-p (n) diff -r 0b59f0204222 -r acbb1860ce62 src/utils.lisp --- a/src/utils.lisp Sat Nov 04 12:47:10 2017 -0400 +++ b/src/utils.lisp Tue Nov 28 18:19:38 2017 -0500 @@ -366,8 +366,7 @@ "Return `n` choose `k`." ;; https://en.wikipedia.org/wiki/Binomial_coefficient#Multiplicative_formula (iterate (for i :from 1 :to k) - (multiplying (/ (+ n 1 (- i)) - i)))) + (multiplying (math (n + 1 - i) / i)))) (defun factorial% (n) @@ -575,8 +574,7 @@ (defun pythagorean-triplet-p (a b c) - (= (+ (square a) (square b)) - (square c))) + (math a ^ 2 + b ^ 2 = c ^ 2)) (defun pythagorean-triplets-of-perimeter (p) (iterate @@ -644,7 +642,7 @@ (defun triangle (n) "Return the `n`th triangle number (1-indexed because mathematicians are silly)." - (* 1/2 n (1+ n))) + (math n (n + 1) / 2)) (defun trianglep (n) "Return whether `n` is a triangle number." @@ -657,16 +655,18 @@ (defun pentagon (n) + (math (3 n ^ 2 - n) / 2) (* n (- (* 3 n) 1) 1/2)) (defun pentagonp (n) ;; We can ignore the - branch of the quadratic equation because negative ;; numbers aren't indexes. - (dividesp (+ 1 (sqrt (1+ (* 24.0d0 n)))) 6)) + (dividesp (math (sqrt (24.0d0 n + 1) + 1)) + 6)) (defun hexagon (n) - (* n (1- (* 2 n)))) + (math (2 n - 1) * n)) (defun hexagonp (n) ;; We can ignore the - branch of the quadratic equation because negative @@ -675,10 +675,11 @@ (defun heptagon (n) - (* n (- (* 5 n) 3) 1/2)) + (math (5 n ^ 2 - 3 n) / 2)) + (defun octagon (n) - (* n (- (* 3 n) 2))) + (math 3 n ^ 2 - 2 n)) (defun parse-strings-file (filename)