broke my brain getting the periodicity function right but now extensi…

…ve tests would suggest that it's now working
mdedwards · Nov 16, 2024 · 27a68b3 · 27a68b3
1 parent 78bbbd6
commit 27a68b3
Show file tree

Hide file tree

Showing 2 changed files with 59 additions and 33 deletions.
diff --git a/src/utilities.lsp b/src/utilities.lsp
@@ -17,7 +17,7 @@
 ;;;
 ;;; Creation date:    June 24th 2002
 ;;;
-;;; $$ Last modified:  10:14:42 Fri Nov 15 2024 CET
+;;; $$ Last modified:  17:43:19 Sat Nov 16 2024 CET
 ;;;
 ;;; ****
 ;;; Licence:          Copyright (c) 2010 Michael Edwards
@@ -6803,33 +6803,40 @@ yes_foo, 1 2 3 4;
 60 
 
 (periodicity '(1 2 3 4 5 6 16))
-480
+240
 
 |#
 ;;; SYNOPSIS
 (defun periodicity (cycle-lengths)
 ;;; ****
   (when (every #'listp cycle-lengths)
-    (setq cycle-lengths (loop for p in cycle-lengths collect (length p))))
-  (assert (and cycle-lengths (listp cycle-lengths)
+    (setq cycle-lengths (mapcar #'length cycle-lengths)))
+  (assert (and (consp cycle-lengths)
                (every #'integer>0 cycle-lengths)))
-  ;; sort in ascending order so that remove-dups below removes the lower value
+  ;; sort in ascending order so that the first in the 'actual' list below is the
+  ;; result 
   (setq cycle-lengths (sort cycle-lengths #'<))
-  ;;          remove simple factors first
-  (let* ((nds (remove-duplicates cycle-lengths :test
-                                 #'(lambda (x y)
-                                     (or (zerop (mod y x))
-                                         (> (gcd x y) 2)))))
-         (largest (first (last nds)))
-         (result (apply #'* nds))
-         (gcd (apply #'gcd nds)))
-    (setq result (/ result gcd))
-    (format t "~&nds: ~a, gcd: ~a, result: ~a" nds gcd result)
-    (loop while (and (> result largest)
-                     (zerop (mod result largest)))
-          do (setq result (/ result 2)))
-    (print (* 2 result))))
-    ;; result))
+  ;; to speed things up remove simple factors (which includes same numbers)
+  (let ((no-dups (remove-duplicates cycle-lengths :test
+                                    #'(lambda (x y) ; x < y
+                                        (factor y x)))))
+    (let* ((big (apply #'* no-dups)) ; this would be the obvious result
+           ;; now, using the obvious number of repeats as a starting point,
+           ;; find out how many repeats each cycle-length would go through
+           ;; before we start over
+           (repeats (loop for cl in no-dups collect (/ big cl)))
+           ;; there might be a common divisor for the number of repeats that's >
+           ;; 1 
+           (gcd (apply #'gcd repeats))
+           ;; make each repeat length a fraction of its previous value by
+           ;; dividing by the greatest common divisor 
+           (actual (loop for c in repeats collect (/ c gcd))))
+      ;; we might now think that we can simply return the first element of
+      ;; actual but if we take (periodicity '(1 2 3 4 5 6 16)) then no-dups is
+      ;; (5 6 16) and the first element of actual is 48 of which 5 is clearly
+      ;; not a factor. So the actual result is the first element of actual * the
+      ;; first element of no-dups
+      (* (first actual) (first no-dups)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; EOF utilities.lsp
diff --git a/tests/sc-test-suite.lsp b/tests/sc-test-suite.lsp
@@ -17,7 +17,7 @@
 ;;;
 ;;; Creation date:    7th December 2011 (Edinburgh)
 ;;;
-;;; $$ Last modified:  09:43:37 Fri Nov 15 2024 CET
+;;; $$ Last modified:  17:25:19 Sat Nov 16 2024 CET
 ;;;
 ;;; SVN ID: $Id: sc-test-suite.lsp 6249 2017-06-07 16:05:15Z medward2 $
 ;;;
@@ -16418,18 +16418,37 @@
     (factor 14 7)
     (not (factor 15 7))))
 
-;;; MDE Wed Nov 13 19:27:07 2024, Heidhausen
+;;;  MDE Wed Nov 13 19:27:07 2024, Heidhausen
 (sc-deftest test-utilities-periodicity ()
-  (flet ((test-it (list period)           
-           (= (periodicity list) period)))
-    (sc-test-check
-      (test-it '(14 35 26) 910)
-      (test-it '(1 2 5) 10)
-      (test-it '((1 2 3) (1 2 3 4 5) (a b c d e f)) 30)
-      (test-it '(1 2 3 4 5 6) 120)
-      (test-it '(1 2 3 4 5 6 20) 60)
-      (test-it '(1 2 3 4 5 6 16) 120)
-      )))
+  (flet ((really-test-it (list &optional period)
+           (print list)
+           (let* ((lists (if (integerp (first list))
+                           (loop for i in list
+                                 collect (make-cscl
+                                          (loop for j below i
+                                                collect (gentemp))))
+                           (mapcar #'make-cscl list)))
+                  (prd (periodicity list))
+                  (all (loop repeat prd
+                             collect (loop for cl in lists
+                                           collect (get-next cl)))))
+             ;; (print all)
+             (and (or (not period) (= prd period))
+                  (= prd (length (remove-duplicates all :test #'equalp)))))))
+    (sc-test-check
+      (really-test-it '(14 35 26) 910)
+      (really-test-it '(1 2 5) 10)
+      (really-test-it '((1 2 3) (1 2 3 4 5) (a b c d e f)) 30)
+      (really-test-it '(1 2 3 4 5 6) 60)
+      (really-test-it '(1 2 3 4 5 6 20) 60)
+      (really-test-it '(1 2 3 4 5 6 16) 240)
+      (notany #'not
+              (loop repeat 100 ; now many we'll test
+                    collect
+                    (really-test-it
+                     ;; num cycles: any more than 8 and things get slow
+                     (loop repeat (+ 2 (random 7)) 
+                           collect (1+ (random 13))))))))) ; elements in cycle
 
 ;;; SAR Mon May  7 23:40:39 BST 2012
 (sc-deftest test-utilities-get-harmonics ()
@@ -18238,7 +18257,7 @@ est)")))
       (file-write-ok "/tmp/mini-1-vn-audio-1-seq1-3.wav" 2500000))))
 
 
-;;;  MDE Tue Apr 17 11:55:59 2012
+;;; MDE Tue Apr 17 11:55:59 2012
 #+clm 
 (sc-deftest test-clm-play-psynch ()
   (let ((mini