1. Shlomi Fish
  2. Lisp Graham Function

Commits

shl...@7334f695-59ef-4367-843d-48bbf0183b29  committed d51096c

Copying the graham-function trunk to its new location

  • Participants
  • Branches default

Comments (0)

Files changed (6)

File Old/graham-test.lisp

View file
+(declaim (optimize (debug 3)))
+
+(defun mult-factors-list (n m)
+    (if (or (null n) (null m))
+      ; If either list is empty return the remaining elements.
+      ;;;;;;;;;;;;;;; (copy-list (concatenate 'list n m))
+      (copy-list (concatenate n m))
+      ; else if the first elements are equal move on
+      (let 
+        ((first-n (car n))
+         (first-m (car m)))
+        (if (= first-n first-m)
+          (mult-factors-list (cdr n) (cdr m))
+          ; Otherwise - append the smallest element.
+          (if (< first-n first-m)
+            (cons first-n (mult-factors-list (cdr n) m))
+            (cons first-m (mult-factors-list n (cdr m))))))))
+

File Test-Suite.lisp

View file
+;;; Load the testing framework
+(load "cybertigger-test.lisp")
+(import 'cybertiggyr-test:deftest)
+
+;;; Load the library to be tested. 
+(load "graham1.lisp")
+
+;;; Define some tests
+(deftest test-squaring-facts-1 ()
+  (equal (get-squaring-facts 1) (list)))
+
+(deftest test-squaring-facts-3 ()
+  (equal (get-squaring-facts 3) (list 3)))
+
+(deftest test-squaring-facts-15 ()
+  (equal (get-squaring-facts 15) (list 3 5)))
+
+(deftest test-squaring-facts-9 ()
+  (equal (get-squaring-facts 9) '()))
+  
+(deftest test-squaring-facts-12 ()
+  (equal (get-squaring-facts 12) '(3)))
+
+(deftest test-squaring-facts-24 ()
+  (equal (get-squaring-facts 24) '(2 3)))
+
+(deftest test-sqfacts-clone-24 ()
+  (let* ((f1 (get-sqfacts-from-n 24))
+         (f2 (clone f1)))
+    (equal (factors f2) '(2 3))))
+
+(deftest test-mult-1 ()
+  (let ((n (get-sqfacts-from-factors '(2 3)))
+        (m (get-sqfacts-from-factors '(2 5))))
+    (equal (factors (mult n m)) '(3 5))))
+
+(deftest test-mult-2 ()
+  (let ((n (get-sqfacts-from-factors '(2 3 5)))
+        (m (get-sqfacts-from-factors '(2 5))))
+    (equal (factors (mult n m)) '(3))))
+
+(deftest test-mult-3 ()
+  (let ((n (get-sqfacts-from-factors '(2 3 5 7)))
+        (m (get-sqfacts-from-factors '(2 5))))
+    (equal (factors (mult n m)) '(3 7))))
+
+(deftest test-mult-4 ()
+  (let ((n (get-sqfacts-from-factors '()))
+        (m (get-sqfacts-from-factors '(2 5))))
+    (equal (factors (mult n m)) '(2 5))))
+
+(deftest test-mult-5 ()
+  (let ((n (get-sqfacts-from-factors '()))
+        (m (get-sqfacts-from-factors '())))
+    (equal (factors (mult n m)) '())))
+
+(deftest test-mult-6 ()
+  (let ((n (get-sqfacts-from-factors '(2 3 7)))
+        (m (get-sqfacts-from-factors '(2 3 7))))
+    (equal (factors (mult n m)) '())))
+
+(deftest test-is-square-1 ()
+  (is-square (get-sqfacts-from-n 25)))
+
+(deftest test-is-square-2 ()
+  (is-square (get-sqfacts-from-n 9)))
+
+(deftest test-is-square-3 ()
+  (is-square (get-sqfacts-from-n 4)))
+
+(deftest test-is-square-4 ()
+  (not (is-square (get-sqfacts-from-n 10))))
+
+(deftest test-is-square-5 ()
+  (not (is-square (get-sqfacts-from-n 5))))
+
+(deftest test-is-square-6 ()
+  (not (is-square (get-sqfacts-from-n 6))))
+
+(deftest test-exists-1 ()
+  (exists (get-sqfacts-from-n 6) 2))
+
+(deftest test-exists-2 ()
+  (exists (get-sqfacts-from-n 6) 3))
+
+(deftest test-exists-3 ()
+  (not (exists (get-sqfacts-from-n 6) 5)))
+
+(deftest test-exists-4 ()
+  (exists (get-sqfacts-from-n 10) 2))
+
+(deftest test-exists-5 ()
+  (not (exists (get-sqfacts-from-n 15) 2)))
+
+;; Test the last-factor method.
+
+(deftest test-last-factor-1 ()
+  (eq (last-factor (get-sqfacts-from-n 6)) 3))
+
+(deftest test-last-factor-2 ()
+  (eq (last-factor (get-sqfacts-from-n 10)) 5))
+
+(deftest test-last-factor-3 ()
+  (eq (last-factor (get-sqfacts-from-n 15)) 5))
+
+(deftest test-last-factor-4 ()
+  (eq (last-factor (get-sqfacts-from-n 2)) 2))
+
+(deftest test-last-factor-5 ()
+  (eq (last-factor (get-sqfacts-from-n 90)) 5))
+
+(deftest test-product-1 ()
+  (eq (product (get-sqfacts-from-n 6)) 6))
+
+(deftest test-product-2 ()
+  (eq (product (get-sqfacts-from-n 18)) 2))
+
+(deftest test-product-3 ()
+  (eq (product (get-sqfacts-from-n (* 3 3 2 2 2 5))) 10))
+
+(deftest test-first-factor-1 ()
+  (eq (first-factor (get-sqfacts-from-n 6)) 2))
+
+(deftest test-first-factor-2 ()
+  (eq (first-factor (get-sqfacts-from-n 10)) 2))
+
+(deftest test-first-factor-3 ()
+  (eq (first-factor (get-sqfacts-from-n 15)) 3))
+
+(deftest test-first-factor-4 ()
+  (eq (first-factor (get-sqfacts-from-n 2)) 2))
+
+(deftest test-first-factor-6 ()
+  (eq (first-factor (get-sqfacts-from-n (* 3 3 3 5))) 3))
+
+(deftest test-first-factor-7 ()
+  (eq (first-factor (get-sqfacts-from-n (* 3 3 5 7 7 7))) 5))
+
+(deftest test-dipole-clone-1 ()
+     (let* ((d (make-dipole :result (get-sqfacts-from-n 10) :compose (get-sqfacts-from-factors '(10))))
+            (d* (clone d)))
+       (equal (factors d*) '(2 5))))
+
+(deftest test-make-dipole-from-n-1 ()
+     (let* ((d (make-dipole-from-n 10))
+            (d* (clone d)))
+       (equal (factors d*) '(2 5))))
+
+(deftest test-dipole-mult-1 ()
+     (let* ((d1 (make-dipole-from-n 10))
+            (d2 (make-dipole-from-n 6))
+            (d* (mult d1 d2)))
+       (and (equal (factors d*) '(3 5))
+            (equal (factors (compose d*)) '(6 10)))))
+
+(deftest test-dipole-is-square-1 ()
+         (let* ((d (make-dipole-from-n 9)))
+           (is-square d)))
+
+(deftest test-dipole-is-square-2 ()
+         (let* ((d (make-dipole-from-n 17)))
+           (not (is-square d))))
+
+(deftest test-graham-func-1 ()
+         (let* ((g (make-instance 'graham-function)))
+           (setf (n g) 5)
+           (eq (n g) 5)))
+
+(deftest test-make-graham-func-1 ()
+         (let* ((g (make-graham-function 5)))
+           (eq (n g) 5)))
+
+;(deftest test-graham-func-5 ()
+;         (let*
+;           ((g (make-graham-function 5)))
+;           (equal (getf (solve g) 'factors) '(5 8 10))))
+(deftest test-graham-func-1 ()
+    (let ((g (make-graham-function 1)))
+      (equal (getf (solve g) 'factors) '(1))))
+
+(deftest test-graham-func-2 ()
+    (let ((g (make-graham-function 2)))
+      (equal (getf (solve g) 'factors) '(2 3 6))))
+
+(deftest test-graham-func-3 ()
+    (let ((g (make-graham-function 3)))
+      (equal (getf (solve g) 'factors) '(3 6 8))))
+
+(deftest test-graham-func-4 ()
+    (let ((g (make-graham-function 4)))
+      (equal (getf (solve g) 'factors) '(4))))
+
+(deftest test-graham-func-5 ()
+    (let ((g (make-graham-function 5)))
+       (equal (getf (solve g) 'factors) '(5 8 10))))
+
+(deftest test-graham-func-6 ()
+    (let ((g (make-graham-function 6)))
+      (equal (getf (solve g) 'factors) '(6 8 12))))
+
+(deftest test-graham-func-7 ()
+    (let ((g (make-graham-function 7)))
+      (equal (getf (solve g) 'factors) '(7 8 14))))
+
+(deftest test-graham-func-8 ()
+    (let ((g (make-graham-function 8)))
+      (equal (getf (solve g) 'factors) '(8 10 12 15))))
+
+(deftest test-graham-func-9 ()
+    (let ((g (make-graham-function 9)))
+      (equal (getf (solve g) 'factors) '(9))))
+
+(deftest test-graham-func-10 ()
+    (let ((g (make-graham-function 10)))
+      (equal (getf (solve g) 'factors) '(10 12 15 18))))
+
+(deftest test-graham-func-11 ()
+    (let ((g (make-graham-function 11)))
+      (equal (getf (solve g) 'factors) '(11 18 22))))
+
+(deftest test-graham-func-12 ()
+    (let ((g (make-graham-function 12)))
+      (equal (getf (solve g) 'factors) '(12 15 20))))
+
+(deftest test-graham-func-13 ()
+    (let ((g (make-graham-function 13)))
+      (equal (getf (solve g) 'factors) '(13 18 26))))
+
+(deftest test-graham-func-14 ()
+    (let ((g (make-graham-function 14)))
+      (equal (getf (solve g) 'factors) '(14 15 18 20 21))))
+
+(deftest test-graham-func-15 ()
+    (let ((g (make-graham-function 15)))
+      (equal (getf (solve g) 'factors) '(15 18 20 24))))
+
+(deftest test-graham-func-16 ()
+    (let ((g (make-graham-function 16)))
+      (equal (getf (solve g) 'factors) '(16))))
+
+(deftest test-graham-func-17 ()
+    (let ((g (make-graham-function 17)))
+      (equal (getf (solve g) 'factors) '(17 18 34))))
+
+(deftest test-graham-func-18 ()
+    (let ((g (make-graham-function 18)))
+      (equal (getf (solve g) 'factors) '(18 24 27))))
+
+(deftest test-graham-func-19 ()
+    (let ((g (make-graham-function 19)))
+      (equal (getf (solve g) 'factors) '(19 24 27 38))))
+
+(deftest test-graham-func-20 ()
+    (let ((g (make-graham-function 20)))
+      (equal (getf (solve g) 'factors) '(20 24 30))))
+
+(deftest test-graham-func-21 ()
+    (let ((g (make-graham-function 21)))
+      (equal (getf (solve g) 'factors) '(21 27 28))))
+
+(deftest test-graham-func-22 ()
+    (let ((g (make-graham-function 22)))
+      (equal (getf (solve g) 'factors) '(22 24 33))))
+
+(deftest test-graham-func-23 ()
+    (let ((g (make-graham-function 23)))
+      (equal (getf (solve g) 'factors) '(23 24 27 46))))
+
+(deftest test-graham-func-24 ()
+    (let ((g (make-graham-function 24)))
+      (equal (getf (solve g) 'factors) '(24 27 32))))
+
+(deftest test-graham-func-25 ()
+    (let ((g (make-graham-function 25)))
+      (equal (getf (solve g) 'factors) '(25))))
+
+(deftest test-graham-func-26 ()
+    (let ((g (make-graham-function 26)))
+      (equal (getf (solve g) 'factors) '(26 27 32 39))))
+
+(deftest test-graham-func-27 ()
+    (let ((g (make-graham-function 27)))
+      (equal (getf (solve g) 'factors) '(27 28 30 32 35))))
+
+(deftest test-graham-func-28 ()
+    (let ((g (make-graham-function 28)))
+      (equal (getf (solve g) 'factors) '(28 32 35 40))))
+
+(deftest test-graham-func-29 ()
+    (let ((g (make-graham-function 29)))
+      (equal (getf (solve g) 'factors) '(29 32 58))))
+
+(deftest test-graham-func-30 ()
+    (let ((g (make-graham-function 30)))
+      (equal (getf (solve g) 'factors) '(30 35 42))))
+
+(deftest test-graham-func-31 ()
+    (let ((g (make-graham-function 31)))
+      (equal (getf (solve g) 'factors) '(31 32 62))))
+
+(deftest test-graham-func-32 ()
+    (let ((g (make-graham-function 32)))
+      (equal (getf (solve g) 'factors) '(32 40 45))))
+
+(deftest test-graham-func-33 ()
+    (let ((g (make-graham-function 33)))
+      (equal (getf (solve g) 'factors) '(33 35 40 42 44))))
+
+(deftest test-graham-func-34 ()
+    (let ((g (make-graham-function 34)))
+      (equal (getf (solve g) 'factors) '(34 35 42 45 51))))
+
+(deftest test-graham-func-35 ()
+    (let ((g (make-graham-function 35)))
+      (equal (getf (solve g) 'factors) '(35 40 42 48))))
+
+(defun %g (n) (solve (make-graham-function n)))
+
+(deftest test-graham-func-36 ()
+    (let ((g (make-graham-function 36)))
+      (equal (getf (solve g) 'factors) '(36))))
+
+(deftest test-graham-func-100 ()
+    (let ((g (make-graham-function 100)))
+      (equal (getf (solve g) 'factors) '(100))))
+
+(cybertiggyr-test:run)

File cybertigger-test.lisp

View file
+;;;
+;;; $Header: /home/gene/library/website/docsrc/lut/RCS/test.lisp,v 1.7 2005/12/29 05:47:43 gene Exp $
+;;;
+;;; Copyright (c) 2005 Gene Michael Stover.  All rights reserved.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301
+;;; USA
+;;;
+
+(defpackage "CYBERTIGGYR-TEST"
+  (:use "COMMON-LISP")
+  (:export "*EXCLUDED-PACKAGES*"
+	   "*PREFIX*"
+	   "CHECK"
+	   "DEFTEST"
+	   "DISPOSITION"
+	   "IS-A-UNIT-TEST"
+	   "NOT-A-UNIT-TEST"
+	   "RATE"
+	   "RATETABLE"
+	   "RUN"
+	   "TEST-FUNCTION-P"
+	   "TEST-FUNCTIONS"))
+
+(in-package "CYBERTIGGYR-TEST")
+
+;;;
+;;; unexported helper functions & stoof
+;;;
+
+(defun symbol-name-starts-with (symbol starts-with)
+  "Return true if & only if the name of the symbol begins with
+the string bound to STARTS-WITH."
+  (let ((len (length starts-with)))
+    (and (>= (length (symbol-name symbol)) len)
+	 (equal (subseq (symbol-name symbol) 0 len) starts-with))))
+
+(defun symbol-bigname (symbol)
+  "Return, as a string, the package name of the symbol & the name
+of the symbol."
+  (format nil "~A::~A" (package-name (symbol-package symbol)) symbol))
+
+(defun make-failed-test-p (max strm)
+  "Return a predicate which runs a test & tells whether it failed.
+The predicate also prints a status to the character output stream
+STRM."
+  (let ((i 0))
+    #'(lambda (test)
+	;; Show which test we're about to run & what percentage
+	;; of the test suit has been run.
+	(format strm "~&~3D% ~A =>" (round (* (/ (incf i) max) 100))
+		(symbol-bigname test))
+	(finish-output strm)
+	(let ((is-good (funcall test))) ; run the test
+	  ;; Show the test's result.
+	  (format strm " ~A" (if is-good "good" "FAILED"))
+	  (not is-good)))))             ; compliment the result
+
+;;;
+;;; You could alter these values to fine-tune the behaviour of
+;;; TEST-FUNCTION-P.  Adding packages to *EXCLUDED-PACKAGES* is
+;;; safe, but altering *PREFIX* could be trouble.
+;;;
+
+(defvar *prefix* "TEST" "String prefix of test function names.")
+
+(defvar *excluded-packages*
+  (remove (find-package "COMMON-LISP-USER") (list-all-packages))
+  "Packages whose functions are not eligible to be test functions.
+Defaults to the packages that were loaded before this package, less
+COMMON-LISP-USER.")
+
+(defun test-function-p (symbol)
+  "Return true if & only if SYMBOL is bound to a test function."
+  (and (fboundp symbol)
+       (not (eq (get symbol 'disposition) 'not-a-unit-test))
+       (not (member (symbol-package symbol) *excluded-packages*))
+       (or (eq (get symbol 'disposition) 'is-a-unit-test)
+	   (symbol-name-starts-with symbol *prefix*))))
+(setf (get 'test-function-p 'disposition) 'not-a-unit-test)
+
+(defun test-functions ()
+  "Return a list of symbols bound to test functions in any package."
+  (let ((lst ()))
+    (do-all-symbols (symbol)
+      (when (test-function-p symbol) (push symbol lst)))
+    (remove-duplicates (sort lst #'string-lessp :key #'symbol-bigname))))
+
+(setf (get 'test-functions 'disposition) 'not-a-unit-test)
+
+(defun run (&optional (strm *standard-output*))
+  "Run all unit tests.  Print results to STRM.  Return true if & only
+if all tests pass."
+  (null
+   (find-if
+    ;; Search for a test function which fails...
+    (make-failed-test-p (length (test-functions)) strm)
+    ;; ...from the suite of test functions.
+    (test-functions))))
+
+(defmacro deftest (name &rest body)
+  "Declare a unit test function.  For now, maps to DEFUN, but could
+be implemented differently in the future."
+  (if (symbol-name-starts-with name *prefix*)
+      `(defun ,name ,@body)
+    ;; else, We'll need to set DISPOSITION
+    `(progn (setf (get ',name 'cybertiggyr-test:disposition)
+		  'cybertiggyr-test:is-a-unit-test)
+	    (defun ,name ,@body))))
+
+(defun rate (fn)
+  "Run function FN at least 3 times & at least 3 seconds.
+Return triple whose FIRST is calls/second, SECOND is number
+of calls, & THIRD is number of seconds.  All three numbers
+will be positive.  They may be integers, ratios, or floating-
+point, depending on details of the lisp system.  Time are
+measured with GET-INTERNAL-REAL-TIME, but they are reported in
+seconds."
+  (declare (type function fn))
+  (do ((start-time (get-internal-real-time))
+       (seconds 0 (/ (- (get-internal-real-time) start-time)
+		      internal-time-units-per-second))
+       (count 0 (1+ count)))
+      ((and (>= count 3) (>= seconds 3))
+       (list (/ count seconds) count seconds))
+      (funcall fn)))
+
+(defun ratetable (names-and-fns strm)
+  "Run RATE on a bunch of functios & return a LaTeX table in a 
+string which shows the results of all of them.  Each element
+in NAMES-AND-FNS is a list whose FIRST is the name of the function
+in a string & whose SECOND is a function of no arguments whose
+performance is to be tested."
+  (format strm "\\begin{tabular}{|r|r|r|r|} \\hline")
+  (format strm "~%{\\bf function} & {\\bf count} &")
+  (format strm " {\\bf seconds} & {\\bf rate}")
+  (format strm " \\\\ \\hline")
+  (dolist (lst names-and-fns)
+    (destructuring-bind (rate count seconds) (rate (second lst))
+      (format strm "~%~A & ~D & ~,2E & ~,2E \\\\ \\hline"
+	      (first lst) count seconds rate)))
+  (format strm "~%\\end{tabular}")
+  strm)
+
+(defmacro check (expression)
+  `(if ,expression
+       t
+     ;; else
+     (progn
+       (format t "~&Failure: ~S" ',expression)
+       nil)))
+
+;;; --- end of file ---

File edit.sh

View file
+#!/bin/bash
+perl_base="$HOME"/progs/perl/Quizes/quiz_of_the_week/8-graham/trunk/modules/Math-GrahamFunction/
+gvim -p graham1.lisp Test-Suite.lisp $perl_base/lib/Math/GrahamFunction.pm

File graham1.lisp

View file
+(declaim (optimize (debug 3)))
+
+;(defun look-for-squaring-facts (n p)
+;  (if (= n 1)
+;    ()
+;    (if (= (mod n p) 0)
+;      ; If it's divisable by p, calculate the division factors
+;      (let ((division-factors (look-for-squaring-facts (truncate (/ n p)) p)))
+;        (if (and (not (null division-factors))
+;                 (= (car division-factors) p))
+;          (cdr division-factors)
+;          (cons p division-factors)))
+;      ; If it's not divisable by p, try the next number.
+;      (look-for-squaring-facts n (1+ p)))))
+
+(defun look-for-squaring-facts (n p)
+  (flet ((recurse ()
+           (let ((division-factors (look-for-squaring-facts (truncate (/ n p)) p)))
+             (if (and (not (null division-factors))
+                      (= (car division-factors) p))
+               (cdr division-factors)
+               (cons p division-factors)))))
+    (cond ((= n 1) ())
+          ; If it's divisable by p, calculate the division factors
+          ((= (mod n p) 0) (recurse))
+          ; If it's not divisable by p, try the next number.
+          (t (look-for-squaring-facts n (1+ p))))))
+
+(defun get-squaring-facts (n)
+  (look-for-squaring-facts n 2))
+
+(defclass sqfacts ()
+  ((factors
+     :initarg :factors)))
+
+(defun get-sqfacts-from-factors (factors)
+  (make-instance 'sqfacts :factors factors))
+
+(defun get-sqfacts-from-n (n)
+  (get-sqfacts-from-factors (get-squaring-facts n)))
+
+(defgeneric factors (f))
+
+(defmethod factors ((f sqfacts))
+  (slot-value f 'factors))
+
+(defgeneric clone (f))
+
+(defmethod clone ((f sqfacts))
+  (get-sqfacts-from-factors (copy-list (factors f))))
+
+(defun mult-factors-list (n m)
+  (if (or (null n) (null m))
+    ; If either list is empty return the remaining elements.
+    (concatenate 'list n m)
+    ; else if the first elements are equal move on
+    (let ((first-n (car n))
+          (first-m (car m)))
+      (if (= first-n first-m)
+        (mult-factors-list (cdr n) (cdr m))
+        ; Otherwise - append the smallest element.
+        (if (< first-n first-m)
+          (cons first-n (mult-factors-list (cdr n) m))
+          (cons first-m (mult-factors-list n (cdr m))))))))
+
+(defgeneric mult (f g))
+(defmethod mult ((n-ref sqfacts) (m-ref sqfacts))
+  (let ((n (factors n-ref))
+        (m (factors m-ref)))
+    (get-sqfacts-from-factors (mult-factors-list n m))))
+
+(defgeneric is-square (n))
+
+(defmethod is-square ((n sqfacts))
+  (null (factors n)))
+
+(defgeneric exists (n f))
+
+(defmethod exists ((n sqfacts) a-factor)
+  (find a-factor (factors n)))
+
+(defgeneric last-factor (n))
+
+(defmethod last-factor ((n sqfacts))
+  (car (last (factors n))))
+
+(defgeneric product (n))
+
+(defmethod product ((n sqfacts))
+  (apply '* (factors n)))
+
+(defgeneric first-factor (n))
+
+(defmethod first-factor ((n sqfacts))
+  (car (factors n)))
+
+(defclass dipole (sqfacts)
+  ((result
+     :initarg :result)
+   (compose
+     :initarg :compose)))
+
+(defun make-dipole (&key result compose)
+  (make-instance 'dipole :result result :compose compose))
+
+(defun make-dipole-from-n (n)
+  (make-dipole :result (get-sqfacts-from-n n) 
+               :compose (get-sqfacts-from-factors (list n))))
+
+(defgeneric result (d))
+
+(defmethod result ((d dipole))
+  (slot-value d 'result))
+
+(defgeneric compose (d))
+
+(defmethod compose ((d dipole))
+  (slot-value d 'compose))
+
+(defmethod clone ((d dipole))
+  (make-dipole :result (clone (result d))
+               :compose (clone (compose d))))
+
+(defmethod factors ((d dipole))
+  (factors (result d)))
+
+(defmethod mult ((d1 dipole) (d2 dipole))
+  (make-dipole :result (mult (result d1) (result d2))
+               :compose (mult (compose d1) (compose d2))))
+
+;; We don't need to over-ride first-factor, exists or is-square because
+;; they access the factors using the "factors" method which was already 
+;; over-rided for dipole.
+
+(defgeneric get-ret (d))
+
+(defmethod get-ret ((d dipole))
+  (copy-list (factors (compose d))))
+
+(eval (list 'defclass 'graham-function ()
+            (map 'list #'(lambda (name) (list name :accessor name)) 
+                 '(base max-base-id n n-vec next-id n-sq-factors primes-to-ids-map))))
+
+(defun make-graham-function (n)
+  (let ((g (make-instance 'graham-function)))
+    (setf (n g) n)
+    (setf (primes-to-ids-map g) (make-hash-table))
+    g))
+
+(defgeneric %get-num-facts (g n))
+
+(defmethod %get-num-facts ((g graham-function) n)
+  (get-sqfacts-from-n n))
+
+(defgeneric %get-facts (g factors))
+
+(defmethod %get-facts ((g graham-function) factors)
+  (get-sqfacts-from-factors factors))
+
+(defgeneric %get-num-dipole (g n))
+
+(defmethod %get-num-dipole ((g graham-function) n)
+  (make-dipole-from-n n))
+
+(defgeneric %calc-n-sq-factors (g))
+
+(defmethod %calc-n-sq-factors ((g graham-function))
+  (setf (n-sq-factors g) (%get-num-dipole g (n g))))
+
+(defgeneric %get-next-id (g))
+
+(defmethod %get-next-id ((g graham-function))
+  (incf (next-id g)))
+
+(defgeneric %get-prime-id (g p))
+
+(defmethod %get-prime-id ((g graham-function) p)
+  (gethash p (primes-to-ids-map g)))
+
+(defgeneric %register-prime (g p))
+
+(defmethod %register-prime ((g graham-function) p)
+  (setf (gethash p (primes-to-ids-map g)) (%get-next-id g)))
+
+(defgeneric %prime-exists (g p))
+
+(defmethod %prime-exists (g p)
+  (%get-prime-id g p))
+
+(defgeneric %get-min-id (g v))
+
+(defmethod %get-min-id ((self graham-function) vec)
+  (reduce #'(lambda (a b) (if (or (not (car a)) (> (car a) (car b))) b a))
+          (map 'list #'(lambda (p) (list (%get-prime-id self p) p))
+               (factors (result vec)))
+          :initial-value (list () 0)))
+
+(defgeneric %try-to-form-n (g))
+
+(defmethod %try-to-form-n ((self graham-function))
+  (if (is-square (n-vec self))
+    t
+    (let ((id (car (%get-min-id self (n-vec self)))))
+      (if (null (gethash id (base self)))
+        nil
+        (progn
+          (setf (n-vec self) (mult (n-vec self) (gethash id (base self))))
+          (%try-to-form-n self))))))
+
+(defgeneric %get-final-factors (g))
+
+(defgeneric %main-solve (self))
+
+(defmethod %get-final-factors ((self graham-function))
+  (%calc-n-sq-factors self)
+  (if (is-square (n-sq-factors self))
+    (get-ret (n-sq-factors self))
+    (%main-solve self)))
+
+(defgeneric solve (g))
+
+(defmethod solve ((self graham-function))
+  (list 'factors (%get-final-factors self)))
+
+(defgeneric %main-init (g))
+
+(defmethod %main-init ((self graham-function))
+  (setf (next-id self) 0)
+  (setf (max-base-id self) -1)
+  (setf (base self) (make-hash-table))
+  (dolist (p (factors (n-sq-factors self))) (%register-prime self p) )
+  (setf (n-vec self) (clone (n-sq-factors self))))
+
+(defgeneric %put-base-vec (g id vec))
+
+(defmethod %put-base-vec ((self graham-function) id vec)
+  (setf (gethash id (base self)) vec)
+  (if (> id (max-base-id self))
+    (setf (max-base-id self) id)))
+
+(defgeneric %update-base (g final-vec))
+
+(defmethod %update-base ((self graham-function) final-vec)
+  (let* ((gmi-ret (%get-min-id self final-vec))
+         (min-id (car gmi-ret))
+         (min-p (cadr gmi-ret)))
+    (when min-id
+      (progn
+        (%put-base-vec self min-id final-vec)
+        (dotimes (j (1+ (max-base-id self)))
+          (let ((vec (gethash j (base self))))
+            (when (and (not (or (= j min-id) (null vec)))
+                       (exists vec min-p))
+                (setf (gethash j (base self)) (mult vec final-vec)))))))))
+
+(defgeneric %get-final-composition (g i-vec))
+
+(defmethod %get-final-composition ((self graham-function) i-vec)
+  (labels ((helper (rest-of-factors final-vec)
+                   (if (null rest-of-factors)
+                     final-vec
+                     (let ((p (car rest-of-factors)))
+                       (if (not (%prime-exists self p))
+                         (progn (%register-prime self p)
+                                (helper (cdr rest-of-factors) final-vec))
+                         (let* ((id (%get-prime-id self p))
+                                (vec (gethash id (base self))))
+                           (helper (cdr rest-of-factors)
+                                   (if vec (mult final-vec vec) final-vec))))))))
+    (helper (factors i-vec) i-vec)))
+
+(defgeneric %get-i-vec (self i))
+
+(defmethod %get-i-vec ((self graham-function) i)
+  (let ((i-vec (%get-num-dipole self i)))
+    ; Skip perfect squares - they do not add to the solution
+    ; 
+    ; Check if $i is a prime number
+    ; We need n > 2 because for n == 2 it does include a prime number.
+    ;
+    ; Prime numbers cannot be included because 2*n is an upper bound
+    ; to G(n) and so if there is a prime p > n than its next multiple
+    ; will be greater than G(n).
+    (if (or (is-square i-vec) (and (> (n self) 2) (= (first-factor i-vec) i)))
+      nil
+      i-vec)))
+
+(defgeneric %solve-iteration (self i))
+
+(defmethod %solve-iteration ((self graham-function) i)
+  (let ((i-vec (%get-i-vec self i)))
+    (if (not i-vec)
+      nil
+      (let ((final-vec (%get-final-composition self i-vec)))
+        (%update-base self final-vec)
+        (if (%try-to-form-n self)
+          (get-ret (n-vec self))
+          nil)))))
+
+
+(defmethod %main-solve ((self graham-function))
+  (%main-init self)
+  ; (do ((i (1+ (n self)) (1+ i))) ((%solve-iteration self i))))
+  (labels ((helper (i) (let ((ret (%solve-iteration self i)))
+                         (if ret ret (helper (1+ i)))))) 
+    (helper (1+ (n self)))))

File rsync.sh

View file
+#!/bin/bash
+rm -fr Exported
+svn export . Exported
+rsync -r -v --progress --rsh=ssh Exported ${__HOMEPAGE_REMOTE_PATH}/Files/files/code/lisp/graham-function/
+