diff --git a/src/utilities.lsp b/src/utilities.lsp index d03ecc8a..eb8ba4b0 100644 --- 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 index 0b62556f..f2f3cd29 100644 --- 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