[PLAIN]
#lang racket/gui
(require racket/gui/base
racket/random
; racket/unsafe/ops
(only-in rnrs/base-6 mod)
; (only-in framework finder:get-file
; finder:put-file)
)
(define-namespace-anchor namespace-anchor)
(define the-namespace (namespace-anchor->namespace namespace-anchor))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(define-setting modulus 24)
;(define-setting length-min 5) ; minimum number of notes in scale
;(define-setting length-max 8) ; maximum number of notes in scale
;
;; wolf intervals, between any two notes in scale
;(define-setting wolves '(13 15))
;
;(define-setting wolf-max 5) ; this many wolves are ok, but no more
;
;(define-setting distance-2-min 1) ; minimum difference between any 2 consecutive notes in scale
;(define-setting distance-3-min 3) ; minimum difference between the lowest and highest notes
; ; of any 3 consecutive notes in scale
;; never use these notes
;(define-setting bad-notes '(1 13 23))
;
;; Scale must not contain any of these cells.
;; Each cell is specified as a list of numbers.
;; The first number is the range, i.e., the number
;; of consecutive notes in the scale that are
;; considered together when checking for the presence
;; of the cell. The rest of the numbers in the list
;; are the notes of the cell.
;(define-setting bad-cells '((3 0 3 4)))
;
;; only these intervals are allowed between consecutive notes in scale
;; (but if the list is empty, all intervals are allowed)
;(define-setting allowed-intervals '(1 3 5))
;
;; #t : scale must contain at least one of each allowed interval
;; #f : scale need not contain every allowed interval
;(define-setting require-all-allowed-intervals #t)
;
;; #t : don't display scale if adding any note to it results in some other displayed scale
;; #f : do
;(define-setting require-completeness #t)
;
;; if you don't care about balance, set both balance-in-min and balance-out-min to 0
;(define-setting balance-notes '(0 2 4 6 8 10 12 14 16 18 20 22))
;(define-setting balance-in-min 1) ; at least this many notes in scale must come from balance-notes
;(define-setting balance-out-min 3) ; at least this many notes in scale must come from outside balance-notes
;
;; #t : display multiple spellings if they're all equally good
;; #f : never display more than one spelling
;(define-setting multiple-spellings #f)
;
;; if more than this number of scales are found,
;; don't display them by default
;(define-setting scales-max 100)
;
;; allowed values are: length packing wolves balance distance rotation
;; any number of them, in any order
;; earlier ones are more important than later ones
;; any of them may be immediately followed by an asterisk to indicate reverse order
;; for example, length* means longer first instead of the usual shorter first
;(define-setting sort-order '(packing))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define settings '())
; the (set! symbol ...) is to convince the compiler that the variable is not constant,
; so that it can be changed later by copy-settings-from-gui-to-vars.
(define-syntax-rule (define-setting symbol label type default)
(begin
(define symbol 'whatever)
(set! symbol 'whatever)
(set! settings (cons (list 'symbol label 'type default) settings))))
(define setting-symbol first)
(define setting-label second)
(define setting-type third)
(define setting-default fourth)
(define-setting modulus "modulus:" number "24")
(define-setting wolves "wolf intervals (between any two notes):" list "13 15")
(define-setting multiple-spellings "display multiple spellings:" boolean #f)
(define-setting scale-tolerance "acceptable error when naming scales (cents):" number "0")
(define-setting sort-order "sort order:" list "length rotation wolves packing")
(define-setting multi-column "abbreviated multiple-column output:" boolean #f)
(define-setting output-format "output format:" choice '("numbers" "letters" "intervals" "keyboard"))
(define-setting column-count "number of output columns:" number "3")
(define-setting keyboard-notes-raw "keyboard notes:" list "")
(define-setting first-note "first note of scale:" number "0")
(define-setting length-min "minimum scale length:" number "6")
(define-setting length-max "maximum scale length:" number "8")
(define-setting wolf-min "minimum number of wolves:" number "0")
(define-setting wolf-max "maximum number of wolves:" number "1")
(define-setting bad-cells-raw "bad cells:" list-of-list "(4 0 1 2)")
(define-setting bad-cell-max "maximum number of bad cells:" number "0")
(define-setting good-cells-raw "good cells:" list-of-list "")
(define-setting good-cell-min "minimum number of good cells:" number "0")
(define-setting distance-2-min "minimum interval between consecutive notes:" number "2")
(define-setting distance-3-min "minimum interval between alternate notes:" number "5")
(define-setting require-completeness "require completeness:" boolean #t)
(define-setting bad-intervals "bad intervals (between consecutive notes):" list "")
(define-setting bad-interval-max "maximum number of bad intervals:" number "0")
(define-setting good-intervals "good intervals (between consecutive notes):" list "")
(define-setting good-interval-min "minimum number of good intervals:" number "0")
(define-setting allowed-intervals "allowed intervals between consecutive notes:" list "")
(define-setting require-all-allowed-intervals "require all allowed intervals:" boolean #f)
(define-setting required-notes "required notes:" list "")
(define-setting forbidden-notes "forbidden notes:" list "1 13 15 23")
(define-setting balance-notes "balance notes:" list "0 2 4 6 8 10 12 14 16 18 20 22")
(define-setting balance-in-min "minimum number of notes from balance:" number "1")
(define-setting balance-out-min "minimum number of notes not from balance:" number "1")
(define-setting scales-max "maximum number of scales to display:" number "100")
(define-setting scale-contents2 "scale:" string "")
(define-setting scale-interpretation "scale is specified as:" choice '("notes" "intervals" "name"))
(define-setting reorder-notes "put notes in order before looking up name:" boolean #t)
(define-setting display-supersets "display all known supersets of scale:" boolean #f)
(define-setting scale-contents3 "scale:" list "0")
(define-setting common-notes "allowed common notes:" list "")
(define-setting max-additional-common-notes "maximum number of additional common notes:" number "0")
(define-setting complement-source "source of possible complements:" choice '("the scale above" "all named scales"))
(define-setting motif "motif:" list "")
(define-setting multiplier-special "evenly spaced multiplier:" boolean #f)
(define-setting multiplier "multiplier:" list "0")
(define-setting multiplicand-order "order of multiplication:" choice '("motif times multiplier" "multiplier times motif" "both"))
(define-setting from-cycle "map from cycle:" list "1")
(define-setting to-cycle "map to cycle:" list "1")
(define-setting mm-order "order of operations:" choice '("map, then multiply" "multiply, then map"))
(define-setting identify-results "identify results:" boolean #f)
(define-setting from-table "map from table:" list-box '())
(define-setting to-table "map to table:" list-box '())
(define-setting row-length "row length:" number "12")
(define-setting mof-bad-cells-raw "bad cells:" list-of-list "")
(define-setting mof-bad-cell-max "maximum number of bad cells:" number "0")
(define-setting mof-good-cells-raw "good cells:" list-of-list "")
(define-setting mof-good-cell-min "minimum number of good cells:" number "0")
(define-setting mof-bad-intervals "bad intervals (between consecutive notes):" list "")
(define-setting mof-bad-interval-max "maximum number of bad intervals:" number "0")
(define-setting mof-good-intervals "good intervals (between consecutive notes):" list "")
(define-setting mof-good-interval-min "minimum number of good intervals:" number "0")
(define-setting distinct-interval-min "minimum number of different intervals:" number "")
(define-setting interval-repetition-max "maximum number of same consecutive intervals:" number "")
(define-setting self-eq-standard "self-equivalence filter - standard:" boolean #t)
(define-setting self-eq-5m "self-equivalence filter - 5m:" boolean #f)
(define-setting self-eq-tolerance "self-equivalence filter tolerance:" number "0")
(define-setting filter-duplicates "remove near-duplicates:" boolean #f)
(define-setting duplicate-tolerance "near-duplicate tolerance:" number "0")
(define-setting wrap-row "wrap when counting cells and intervals:" boolean #t)
(define-setting spacing-row-length "virtual row length, for computing spacing:" number "13")
(define-setting motif-length "motif length:" number "12")
(define-setting standard-transforms "look for standard transformations of motif:" boolean #t)
(define-setting 5m-transforms "look for 5m transformations of motif:" boolean #f)
(define-setting spacing-min "minimum spacing:" number "")
(define-setting spacing-max "maximum spacing:" number "")
(define-setting spacing-error-min "minimum number of violations of min/max spacing:" number "0")
(define-setting spacing-error-max "maximum number of violations of min/max spacing:" number "0")
(define-setting 1-space-min "minimum number of 1-spaces:" number "0")
(define-setting 1-space-max "maximum number of 1-spaces:" number "0")
(define-setting motif-min "minimum number of occurrences of motif in row:" number "")
(define-setting wrap-spacing "wrap when computing spacing:" boolean #t)
(define-setting rows-max "maximum number of rows to display:" number "100")
(define-setting results-file "file of results to search within:" string "")
(set! settings (reverse settings))
(define (padding str len)
(make-string (- len (string-length str))
#\space))
(define (setting-length s)
(string-length (setting-label s)))
(define (display-setting s len)
(let ((label (setting-label s)))
(display (padding label len))
(display label))
(display #\space)
(display (eval (setting-symbol s) the-namespace)))
(define first-setting
(vector 'modulus 'keyboard-notes-raw 'scale-contents2 'scale-contents3 'motif 'row-length 'the-end))
(define (get-settings tab)
(define (not-yet n)
(lambda (s) (not (eq? (setting-symbol s) (vector-ref first-setting n)))))
(takef (dropf settings (not-yet tab))
(not-yet (+ 1 tab))))
(define (display-settings tab)
(let* ((ss (append (get-settings 0) (get-settings tab)))
(len (apply max (map setting-length ss))))
(for-each (lambda (s)
(display-setting s len)
(newline))
ss)
(newline)))
(define gui-fields (make-hash))
(define the-frame (new frame% (label "microtonal scales")))
(define the-tabs (new tab-panel%
(parent the-frame)
(choices '("common" "generate" "identify" "complement" "mmm" "mof"))
(callback (lambda (tp e)
(send tp change-children
(lambda (x)
(case (send tp get-selection)
((0) (list common-panel))
((1) (list generate-panel))
((2) (list identify-panel))
((3) (list complement-panel))
((4) (list mmm-panel))
((5) (list mof-panel)))))))))
(send the-tabs set-selection 1)
(define (make-tab-panel show?)
(new vertical-panel%
(parent the-tabs)
(style (if show? '() '(deleted)))))
(define (make-tab-pane p)
(new horizontal-pane%
(parent p)))
(define common-panel (make-tab-panel #f))
(define generate-panel (make-tab-panel #t))
(define identify-panel (make-tab-panel #f))
(define complement-panel (make-tab-panel #f))
(define mmm-panel (make-tab-panel #f))
(define mof-panel (make-tab-panel #f))
(define common-pane (make-tab-pane common-panel))
(define generate-pane (make-tab-pane generate-panel))
(define identify-pane (make-tab-pane identify-panel))
(define complement-pane (make-tab-pane complement-panel))
(define mmm-pane (make-tab-pane mmm-panel))
(define mof-pane (make-tab-pane mof-panel))
(define (make-column p (subcolumn #f))
(let* ((column (new vertical-pane%
(parent p)
(border (if subcolumn 0 5))))
(column-top (new horizontal-pane%
(parent column)
(stretchable-height subcolumn))))
(let ((labels (new vertical-pane%
(parent column-top)
(stretchable-width #f)))
(fields (new vertical-pane%
(parent column-top)
(alignment '(left center)))))
(list column labels fields))))
(define column-whole first)
(define column-labels second)
(define column-fields third)
(define column-0-0 (make-column common-pane))
(define column-0-1 (make-column common-pane))
(define column-1-0 (make-column generate-pane))
(define column-1-1 (make-column generate-pane))
(define column-2 (make-column identify-pane))
(define column-3 (make-column complement-pane))
(define column-4-0a (make-column mmm-pane))
(define column-4-0b (make-column (column-whole column-4-0a) #t))
(define column-4-1 (make-column mmm-pane))
(define column-5-0 (make-column mof-pane))
(define column-5-1 (make-column mof-pane))
(define-values (check-box-height text-field-height choice-height)
(let ((frame (new frame% (label "test"))))
(let ((cb (new check-box% (parent frame) (label "")))
(tf (new text-field% (parent frame) (label #f)))
(ch (new choice% (parent frame) (label #f) (choices '("hi")))))
(let ((cb-margin (send cb vert-margin))
(tf-margin (send tf vert-margin))
(ch-margin (send ch vert-margin)))
(let-values (((dummy1 cb-height) (send cb get-graphical-min-size))
((dummy2 tf-height) (send tf get-graphical-min-size))
((dummy3 ch-height) (send ch get-graphical-min-size)))
(let ((max-height (max (+ cb-margin cb-height)
(+ tf-margin tf-height)
(+ ch-margin ch-height))))
(values (- max-height cb-margin)
(- max-height tf-margin)
(- max-height ch-margin))))))))
(define (add-gui-field setting column)
(let ((labels-pane (column-labels column))
(fields-pane (column-fields column)))
(let* ((field-label (new message%
(parent (new pane%
(parent labels-pane)
(alignment '(right center))))
(label (setting-label setting))))
(field-class (case (setting-type setting)
((boolean) check-box%)
((number string list list-of-list) text-field%)
((choice) choice%)
((list-box) list-box%)))
(the-field (cond
((eq? field-class check-box%) (new check-box%
(parent fields-pane)
(label "")
(min-height check-box-height)))
((eq? field-class text-field%) (new text-field%
(parent fields-pane)
(label #f)
(min-height text-field-height)))
((eq? field-class choice%) (new choice%
(parent fields-pane)
(label #f)
(choices (setting-default setting))
(min-height choice-height)))
((eq? field-class list-box%) (new list-box%
(parent fields-pane)
(label #f)
(style '(multiple))
(choices (setting-default setting)))))))
(when (member field-class (list check-box% text-field%))
(send the-field set-value (setting-default setting)))
(hash-set! gui-fields (setting-symbol setting) the-field))))
(let recur ((ss settings)
(col column-0-0))
(when (pair? ss)
(let ((s (car ss)))
(add-gui-field s col)
(recur (cdr ss) (case (setting-symbol s)
((column-count) column-1-0)
((good-cell-min) column-1-1)
((scales-max) column-2)
((display-supersets) column-3)
((complement-source) column-4-0a)
((identify-results) column-4-0b)
((to-table) column-5-0)
((wrap-row) column-5-1)
(else col))))))
(define (make-help-field col txt)
(let ((help-field (new text-field%
(parent (column-whole col))
(label #f)
(style '(multiple))
(enabled #f))))
(send help-field set-value txt)))
(make-help-field column-0-1 "Sort order may be any combination of:\n\n length packing wolves\n balance distance rotation\n\nAny of them may be immediately followed by an asterisk, in which case the usual order will be reversed. For example, length* means longer scales will come first, instead of shorter ones.")
(make-help-field column-1-0 "Each cell is written as a parenthesized list of numbers. The first number is the number of consecutive notes of the scale being considered within which the cell must be found if it is to count. The rest of the numbers are the notes of the cell.")
(make-help-field column-4-1 "The fields 'map from cycle' and 'map to cycle' can each contain one, two, or three numbers. One number means just that number. Two numbers means all numbers between the two (including the two). Three numbers means all numbers you get by starting from the first and repeatedly adding the third until reaching the second.\n\nIf 'evenly spaced multiplier' is unchecked, the 'multiplier' field should contain the list of pitches to be multiplied by the motif. If checked, the 'multiplier' field indirectly represents a list of pitches. It should contain three numbers: the first pitch of the list, the spacing between successive pitches, and the number of pitches.")
(define (nesting-level x)
(cond
((pair? x) (+ 1 (nesting-level (car x))))
((null? x) 1)
(else 0)))
(define (increase-nesting-level str n)
(string-append (make-string n #\( )
str
(make-string n #\) )))
(define (nest str n)
(let ((x (read (open-input-string str))))
(if (eof-object? x)
(if (zero? n) 0 '())
(read (open-input-string (increase-nesting-level str (- n (nesting-level x))))))))
(define (nest-appropriately val type)
(case type
((string boolean
choice list-box) val)
((number) (nest val 0))
((list) (nest val 1))
((list-of-list) (nest val 2))))
(define (get-field-value sym)
(let ((f (hash-ref gui-fields sym)))
(cond
((is-a? f choice%) (send f get-string-selection))
((is-a? f list-box%) (send f get-selections))
((or (is-a? f text-field%)
(is-a? f check-box%)) (send f get-value)))))
(define (set-list-box-selections box ns)
(if (null? ns)
(when (positive? (send box get-number))
(send box set-selection 0)
(send box select 0 #f))
(begin
(send box set-selection (car ns))
(for-each (lambda (n) (send box select n))
(cdr ns)))))
(define (set-field-value sym val)
(let ((f (hash-ref gui-fields sym)))
(cond
((is-a? f choice%) (send f set-string-selection val))
((is-a? f list-box%) (set-list-box-selections f val))
((or (is-a? f text-field%)
(is-a? f check-box%)) (send f set-value val)))))
(define (copy-settings-from-gui-to-vars)
(for-each (lambda (s)
(let* ((sym (setting-symbol s))
(val (nest-appropriately (get-field-value sym) (setting-type s))))
(eval `(set! ,sym ',val) the-namespace)))
settings))
(define (get-data-from-gui)
(map (lambda (s)
(let ((sym (setting-symbol s)))
(list sym (get-field-value sym))))
settings))
(define (set-gui-from-data data)
(for-each (lambda (x)
(set-field-value (car x) (cadr x)))
data))
; writer is a function of one argument, an output port, and writes stuff to it
(define (save-to-file writer)
(let ((file (put-file)))
(when file
(call-with-output-file file writer #:mode 'text #:exists 'replace))))
; reader is a function of one argument, an input port, and reads stuff from it
(define (load-from-file reader)
(let ((file (get-file)))
(when file
(call-with-input-file file reader))))
(define (write-list lst p)
(displayln "(" p)
(for-each (lambda (x) (writeln x p))
lst)
(displayln ")" p))
(define (save-settings-to-file)
(save-to-file (lambda (p) (write-list (get-data-from-gui) p))))
(define (load-settings-from-file)
(load-from-file (lambda (p) (set-gui-from-data (read p)))))
(define (write-results p)
(write-list settings-in-use p)
(write-list found-scales p))
(define (normalize-results-path path)
(path->string (simple-form-path path)))
(define (set-loaded-results-path path set-results-file)
(let ((s (normalize-results-path path)))
(set! loaded-results-path s)
(when set-results-file
(set-field-value 'results-file s))))
(define (read-results path button-pressed)
(call-with-input-file path
(lambda (p)
(let ((data (read p)))
(when button-pressed
(set-gui-from-data data)))
(set! loaded-results (read p))))
(set-loaded-results-path path button-pressed))
(define (save-results-to-file)
(save-to-file write-results))
(define (load-results-from-file)
(let ((file (get-file)))
(when file
(read-results file #t))))
(define (save-and-load-results)
(let ((file (put-file)))
(when file
(call-with-output-file file write-results #:mode 'text #:exists 'replace)
(set-gui-from-data settings-in-use)
(set! loaded-results found-scales)
(set-loaded-results-path file #t))))
(define (clear-results)
(set-field-value 'results-file "")
(set! loaded-results '())
(set! loaded-results-path ""))
(define please-stop #f)
(define stop-buttons '())
(define (set-going-state b)
(for-each (lambda (button) (send button enable b))
stop-buttons)
(for-each (lambda (button) (send button enable (not b)))
other-buttons))
(define (make-go-button p f)
(new button%
(parent p)
(label "go")
(callback (lambda (b e)
(set-going-state #t)
(set! please-stop #f)
(thread (lambda ()
(dynamic-wind
(lambda () 'whatever)
f
(lambda () (set-going-state #f)))))))))
(define (make-stop-button p)
(let ((button (new button%
(parent p)
(label "stop")
(enabled #f)
(callback (lambda (b e)
(set! please-stop #t))))))
(set! stop-buttons (cons button stop-buttons))
button))
(define (make-buttons-pane p)
(new horizontal-pane%
(parent p)
(alignment '(center center))
(border 5)
(stretchable-height #f)))
(define buttons-pane-0 (make-buttons-pane common-panel))
(define save-settings-button (new button%
(parent buttons-pane-0)
(label "save settings")
(callback (lambda (b e)
(save-settings-to-file)))))
(define load-settings-button (new button%
(parent buttons-pane-0)
(label "load settings")
(callback (lambda (b e)
(load-settings-from-file)))))
(define buttons-pane-1 (make-buttons-pane generate-panel))
(define generate-go-button (make-go-button buttons-pane-1 (lambda () (generate))))
(define generate-stop-button (make-stop-button buttons-pane-1))
(define buttons-pane-2 (make-buttons-pane identify-panel))
(define identify-button (new button%
(parent buttons-pane-2)
(label "identify")
(callback (lambda (b e)
(set! please-stop #f)
(thread identify)))))
(define list-button (new button%
(parent buttons-pane-2)
(label "list")
(callback (lambda (b e)
(thread list-known-scales)))))
(define buttons-pane-3 (make-buttons-pane complement-panel))
(define complement-button (new button%
(parent buttons-pane-3)
(label "complement")
(callback (lambda (b e)
(set! please-stop #f)
(thread complement)))))
(define buttons-pane-4 (make-buttons-pane mmm-panel))
(define mmm-button (new button%
(parent buttons-pane-4)
(label "mmm")
(callback (lambda (b e)
(set! please-stop #f) ; necessary if display-scales gets called
(thread mmm)))))
(define buttons-pane-5 (make-buttons-pane mof-panel))
(define save-results-button (new button%
(parent buttons-pane-5)
(label "save results")
(callback (lambda (b e)
(save-results-to-file)))))
(define load-results-button (new button%
(parent buttons-pane-5)
(label "load results")
(callback (lambda (b e)
(load-results-from-file)))))
(define save-load-button (new button%
(parent buttons-pane-5)
(label "save and load results")
(callback (lambda (b e)
(save-and-load-results)))))
(define clear-results-button (new button%
(parent buttons-pane-5)
(label "clear results")
(callback (lambda (b e)
(clear-results)))))
(define mof-go-button (make-go-button buttons-pane-5 (lambda () (mof))))
(define mof-stop-button (make-stop-button buttons-pane-5))
(define other-buttons (list save-settings-button
load-settings-button
generate-go-button
identify-button
list-button
complement-button
mmm-button
save-results-button
load-results-button
save-load-button
clear-results-button
mof-go-button))
; A note is represented as a nonnegative integer less than modulus.
; A scale is represented as a list of notes. As it's being built,
; it's in decreasing order. Once it's complete, it's reversed
; into increasing order before being added to 'found-scales'.
; (Sort of. See function note-comparer.)
(define found-scales '()) ; initially empty list, onto which scales are consed as they are found
(define allowed-notes '()) ; notes that may be included in a scale
(define bad-cells '()) ; bad cells, after being preprocessed
(define good-cells '()) ; good cells, after being preprocessed
(define keyboard-notes '())
(define keyboard #f) ; vector, of length modulus, mapping notes to keyboard keys
(define (interval a b)
(modulo (- b a) modulus))
; transpose note n by k, where modulus is m
(define (transpose-note m n k)
(modulo (+ n k) m))
; transpose scale s by k, where modulus is m
(define (transpose-scale m s k)
(map (lambda (n) (transpose-note m n k))
s))
; invert note n, where modulus is m
(define (invert-note m n)
(modulo (- n) m))
; invert scale s, where modulus is m
(define (invert-scale m s)
(map (lambda (n) (invert-note m n))
s))
(define (invert-scale-m s)
(invert-scale modulus s))
(define note-names
'#(("A" ) ; 0
("A+" "A#-" "Bb-") ; 1
("A#" "Bb" ) ; 2
("A#+" "Bb+" "B-" ) ; 3
("B" ) ; 4
("B+" "C-" ) ; 5
("C" ) ; 6
("C+" "C#-" "Db-") ; 7
("C#" "Db" ) ; 8
("C#+" "Db+" "D-" ) ; 9
("D" ) ; 10
("D+" "D#-" "Eb-") ; 11
("D#" "Eb" ) ; 12
("D#+" "Eb+" "E-" ) ; 13
("E" ) ; 14
("E+" "F-" ) ; 15
("F" ) ; 16
("F+" "F#-" "Gb-") ; 17
("F#" "Gb" ) ; 18
("F#+" "Gb+" "G-" ) ; 19
("G" ) ; 20
("G+" "G#-" "Ab-") ; 21
("G#" "Ab" ) ; 22
("G#+" "Ab+" "A-" ) ; 23
))
; A name code represents, e.g., F#+, as
; a list of three numbers, one for the F,
; one for the # and one for the +.
;
; first number: A through G are 0 through 6, respectively.
; second number: b is -1, # is +1, none is 0.
; third number: - is -1, + is +1, none is 0.
(define code-values
'((#\A . 0)
(#\B . 1)
(#\C . 2)
(#\D . 3)
(#\E . 4)
(#\F . 5)
(#\G . 6)))
; assumes name is properly capitalized
; i.e., first letter is capital, rest aren't
(define (name->code name)
(let ((lst (string->list name)))
(let ((letter (car lst))
(accidentals (cdr lst)))
(list
(cdr (assoc letter code-values))
(cond
((member #\b accidentals) -1)
((member #\# accidentals) +1)
(else 0))
(cond
((member #\- accidentals) -1)
((member #\+ accidentals) +1)
(else 0))))))
(define (code->name code)
(let ((x (car code))
(y (cadr code))
(z (caddr code)))
(string-append
(string (car (list-ref code-values x)))
(case y
((-1) "b")
((+1) "#")
(else ""))
(case z
((-1) "-")
((+1) "+")
(else "")))))
; same structure as note-names, i.e. vector of lists,
; except with each name replaced by the corresponding code
(define name-codes
(vector-map (lambda (name-list) (map name->code name-list))
note-names))
(define note-values
'((#\A . 0)
(#\B . 4)
(#\C . 6)
(#\D . 10)
(#\E . 14)
(#\F . 16)
(#\G . 20)
(#\# . 2)
(#\b . -2)
(#\+ . 1)
(#\- . -1)))
(define (string->note s)
(apply +
(map (lambda (c) (cdr (assoc c note-values)))
(let ((cs (string->list s)))
(cons (char-upcase (car cs))
(map char-downcase (cdr cs)))))))
(define (minimum less xs)
(foldl (lambda (x m) (if (less x m) x m))
(car xs) (cdr xs)))
; returns a function that compares two lists lexicographically,
; returning true if the first precedes the second.
; corresponding elements of the lists are compared using 'less'.
(define (comparer less)
(letrec ((f (lambda (a b)
(or (and (null? a) (pair? b))
(and (pair? a) (pair? b)
(or (less (car a) (car b))
(and (not (less (car b) (car a)))
(f (cdr a) (cdr b)))))))))
f))
(define (sorter key less)
(lambda (lst)
(sort lst less #:key key #:cache-keys? #t)))
(define (rotate-scale m s)
(let ((t (append (cdr s) (list (car s)))))
(transpose-scale m t (- (car t)))))
; list of rotations of scale
; scale itself is the first one
(define (all-rotations m scale)
(let recur ((n (- (length scale) 1))
(rs (list (rotate-scale m scale))))
(if (zero? n)
rs
(recur (- n 1) (cons (rotate-scale m (car rs)) rs)))))
(define (all-rotations-m scale)
(all-rotations modulus scale))
(define (least-rotation m scale)
(minimum (comparer <) (all-rotations m scale)))
(define (least-rotation-m scale)
(least-rotation modulus scale))
(define (scale-sorter x)
(case x
((length) (sorter length <))
((length*) (sorter length >))
((packing) (sorter values (comparer <)))
((packing*) (sorter values (comparer >)))
((wolves) (sorter count-all-wolves <))
((wolves*) (sorter count-all-wolves >))
((balance) (sorter count-balance-out <))
((balance*) (sorter count-balance-out >))
((distance) (sorter least-distance-3 <))
((distance*) (sorter least-distance-3 >))
((rotation) (sorter least-rotation-m (comparer <)))
((rotation*) (sorter least-rotation-m (comparer >)))
(else (string-append "I don't know how to sort by " (symbol->string x) "."))))
; name of scale followed by its intervals
(define scale-list-1
'(
("Whole-Tone" 2 2 2 2 2 2)
("Augmented 1-3" 1 3 1 3 1 3)
("Lydian" 2 2 2 1 2 2 1)
("Harmonic Major" 1 3 1 2 2 1 2)
("Harmonic Minor" 2 1 2 2 1 3 1)
("Ascending Melodic Minor" 2 1 2 2 2 2 1)
("Octatonic-Diminished" 1 2 1 2 1 2 1 2)
("Rast" 4 3 3 4 4 3 3)
("Dastgah-e Chahargah" 3 5 2 4 3 5 2)
("Sikah Baladi" 3 4 3 4 3 4 3)
("Nahfat" 3 3 4 4 4 2 4)
; ("Mahur" 4 3 3 4 4 4 2)
("Saba" 3 3 2 6 2 4 4)
("Sabr Jadid" 3 3 2 6 2 6 2)
("Suznak" 4 3 3 4 2 6 2)
; ("Qarjighar" 3 3 4 2 6 2 4)
; ("Hizam" 3 4 2 6 2 4 3)
("Nawa" 2 4 4 4 3 3 4)
("Higaz-kar" 2 5 3 4 2 5 3)
("Dastgah" 3 5 2 4 2 4 4)
; ("Naghmeh Esfahan" 4 2 4 4 3 5 2)
("Aug-ara" 3 6 1 5 2 6 1)
("Buselik" 4 1 5 4 2 6 2)
("Neuter" 4 2 6 2 2 5 3)
("Ushaq&Yi" 4 3 3 4 4 2 4)
; ("Su'ar" 3 4 4 2 4 4 3)
; ("Ushaq Masri" 4 2 4 4 3 3 4)
; ("'Ushshaq Turki" 3 3 4 4 2 4 4)
; ("Jahargah" 4 4 2 4 4 3 3)
("Daniel" 4 4 2 3 1 4 6)
("Oceans Eleven HF2" 3 4 4 3 5 2 3)
("Oceans Eleven Tropicana" 3 4 4 3 3 2 5)
("Oceans Eleven Squeeze" 5 2 4 3 3 2 5)
("Cicada Climbs Wall" 8 3 3 2 5 3)
("Cicada Sox Six" 8 3 3 2 3 5)
("Cal's Hex 3437" 3 4 3 7 4 3)
("Cal's Hex 3433" 3 3 4 7 3 4)
("Cal's Hex 3434" 3 4 3 4 3 7)
("31 LYDIAN GROUP" 5 5 5 3 5 5 3)
("31 No-Wolf 7-of-Oct" 3 5 2 6 2 8 5)
("31 Harmonic Major" 5 5 3 5 3 7 3)
("31 Harmonic Major2" 5 5 3 5 2 8 3)
("31 Melodic Minor Up" 3 5 5 5 5 3 5)
("31 Harmonic Minor" 5 3 5 5 3 7 3)
("Kanakangi-0125789" 1 1 3 2 1 1 3)
("Ratnangi-012578T" 1 1 3 2 1 2 2)
("Ganamurti-0124679" 1 1 2 2 1 2 3)
("Vanaspati-012579T" 1 1 3 2 2 1 2)
("Manavati-012579E" 1 1 3 2 2 2 1)
("Tanarupi-01257TE" 1 1 3 2 3 1 1)
("Senavati-0135789" 1 2 2 2 1 1 3)
("Dhenuka-013578B" 1 2 2 2 1 3 1)
("Kokilapriya-013579B" 1 2 2 2 2 2 1)
("Rupavati-01357TE" 1 2 2 2 3 1 1)
("Gayak-0145789" 1 3 1 2 1 1 3)
("Mayam-014578E" 1 3 1 2 1 3 1)
("Hatak-01457TE" 1 3 1 2 3 1 1)
("Varu-02357TE" 2 1 2 2 3 1 1)
("Nagan-02457TE" 2 2 1 2 3 1 1)
("Yaga-0345789" 3 1 1 2 1 1 3)
("Gangey-034578E" 3 1 1 2 1 3 1)
("Chalanata-03457TE" 3 1 1 2 3 1 1)
("Salagam-0126789" 1 1 4 1 1 1 3)
("Jalarn-012678T" 1 1 4 1 1 2 2)
("Jhala-012678E" 1 1 4 1 1 3 1)
("Navam-012679T" 1 1 4 1 2 1 2)
("Pavani-012679E" 1 1 4 1 2 1 2)
("Rhagu-01267TE" 1 1 4 1 3 1 1)
("Sadvid-013679T" 1 2 3 1 2 1 2)
("Suvarn-013679E" 1 2 3 1 2 2 1)
("Dvya-01367TE" 1 2 3 1 3 1 1)
("Dhava-0146789" 1 3 2 1 1 1 3)
("Naman-014678T" 1 3 2 1 1 2 2)
("Sucha-0346789" 3 1 2 1 1 1 3)
("Jioti-034678T" 3 1 2 1 1 2 2)
("Target" 4 3 4 3 5 2 3)
("Nice" 3 2 5 7 4 3)
("118-Harmonic11L" 20 18 16 15 14 12 23)
("118-Mu-Trane11" 20 18 16 15 49)
("Mu-Trane11qt" 4 4 3 3 10)
("WideLydian190" 34 34 34 10 34 34 10)
("HybridLydian190" 33 33 33 11 33 33 14)
("MedLydian190" 32 32 32 15 32 32 15)
("5LimJI-Lydian190" 32 33 28 18 32 29 18)
("NarrowLydian190" 30 30 30 20 30 30 20)
("Large Dorian 136" 24 8 16 8 24 24 8 24)
("Melodic Minor 136" 23 10 23 24 23 20 13)
("Harmonic171 8-15" 29 26 24 21 20 18 17 16)
("Harmonic 7n 171 8-14" 29 26 24 21 20 18 33)
("Harmonic 6n 171 8-14" 29 26 24 21 38 33)
("5-note Equal" 1 1 1 1 1)
("7-note Equal" 1 1 1 1 1 1 1)
("8-note Equal" 1 1 1 1 1 1 1 1)
("9-note Equal" 1 1 1 1 1 1 1 1 1)
("10-note Equal" 1 1 1 1 1 1 1 1 1 1)
("11-note Equal" 1 1 1 1 1 1 1 1 1 1 1)
("12-note Equal" 1 1 1 1 1 1 1 1 1 1 1 1)
("17-note Equal" 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
("19-note Equal" 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
))
; name of scale, then its modulus, then its notes
(define scale-list-2
'(
("row 9" 12 0 3 11 2 10 8 5 1 4 9 6 7)
("row 8" 12 0 3 6 2 9 4 5 11 10 8 1 7)
("row 7" 12 0 2 8 11 7 3 4 10 9 6 1 5)
("row 6" 12 0 1 8 10 7 5 2 9 11 6 3 4)
("row 5" 12 0 10 6 9 5 2 11 8 7 4 1 3)
("row 4" 12 0 8 5 7 4 1 10 6 9 3 11 2)
("row 3" 12 0 9 2 6 4 10 11 5 7 3 8 1)
("row 2" 12 0 6 3 5 2 11 8 4 7 1 9 10)
("row 1" 12 0 4 1 3 8 11 5 2 9 7 10 6)
("mof8" 12 0 4 11 6 8 2 3 5 7 10 1 9)
("mof7" 12 0 4 11 5 8 1 3 10 7 9 6 2)
("mof6A" 12 0 4 10 5 8 1 2 11 6 9 7 3)
("mof6B" 12 0 4 9 6 8 2 1 11 5 10 7 3)
("mof5" 12 0 4 7 5 8 1 11 6 3 9 2 10)
("mof4A" 12 0 4 7 2 8 10 11 5 3 6 1 9)
("mof4B" 12 0 4 7 2 8 10 11 1 3 6 9 5)
("mof3" 12 0 4 6 3 8 11 10 5 2 7 1 9)
("mof2A" 12 0 4 1 10 8 6 5 11 9 2 7 3)
("mof2B" 12 0 4 1 10 8 6 5 3 9 2 11 7)
("mallalieu" 12 0 1 4 2 9 5 11 3 8 10 7 6)
))
; return a list whose first element is the scale's modulus
; and whose remaining elements are its notes
(define (intervals->notes is)
(let recur ((is is)
(ns '(0)))
(if (null? is)
(cons (car ns) ; modulus
(reverse (cdr ns))) ; notes
(recur (cdr is)
(cons (+ (car ns) (car is))
ns)))))
; lst is not empty
; return list of results of calling f on pairs of elements of lst:
; first and second, second and third, ..., last and first
; result has same length as lst (so, when lst has one element, x,
; result is a list with the single element (f x x))
(define (map2 f lst)
(let ((a (car lst)))
(let recur ((lst lst))
(if (null? (cdr lst))
(list (f (car lst) a))
(cons (f (car lst) (cadr lst))
(recur (cdr lst)))))))
; like map2, except don't call f on last and first
; result is therefore shorter than lst by one
(define (map2a f lst)
(if (null? (cdr lst))
'()
(cons (f (car lst) (cadr lst))
(map2a f (cdr lst)))))
(define (notes->intervals ns)
(map2 interval ns))
(define (divide-by-gcd lst)
(let ((k (apply gcd lst)))
(map (lambda (j) (/ j k))
lst)))
; first element of scale is the modulus, rest are the notes
; same for return value
(define (normalize scale)
(divide-by-gcd (cons (car scale) (least-rotation (car scale) (cdr scale)))))
; maps modulus-prefixed scale to name
(define known-scales (make-hash))
; first element of scale is its modulus, rest are its notes
(define (add-scale name scale)
(let ((normalized-scale (normalize scale)))
(hash-update! known-scales normalized-scale
(lambda (x) (or x name))
#f)))
; first element of scale is its modulus, rest are its notes
(define (add-scale-and-inverse name scale)
(let ((m (car scale))
(notes (cdr scale)))
(add-scale name scale)
(add-scale (string-append name "*") (cons m (invert-scale m notes)))))
; first element of s is scale's name, rest are its intervals
(define (add-scale-from-intervals s)
(add-scale-and-inverse (car s) (intervals->notes (cdr s))))
; first element of s is scale's name, next is its modulus, rest are its notes
(define (add-scale-from-notes s)
(add-scale-and-inverse (car s) (cdr s)))
(for-each add-scale-from-intervals scale-list-1)
(for-each add-scale-from-notes scale-list-2)
; first element of scale is the modulus, rest are the notes
; return value is just notes
(define (convert-to-mod-1 scale)
(map (lambda (n) (/ n (car scale)))
(cdr scale)))
(define (interval-1 a b)
(mod (- b a) 1))
; transpose note n by k, where modulus is 1
(define (transpose-note-1 n k)
(mod (+ n k) 1))
; transpose scale s by k, where modulus is 1
(define (transpose-scale-1 s k)
(map (lambda (n) (transpose-note-1 n k))
s))
; s is mod 1
(define (rotate-scale-1 s)
(let ((t (append (cdr s) (list (car s)))))
(transpose-scale-1 t (- (car t)))))
; scale is mod 1
(define (all-rotations-1 scale)
(let recur ((n (- (length scale) 1))
(rs (list (rotate-scale-1 scale))))
(if (zero? n)
rs
(recur (- n 1) (cons (rotate-scale-1 (car rs)) rs)))))
; s1 and s2 are mod 1 and have the same length
; return the largest difference between any two corresponding
; notes of scales s1 and s2 (i.e., the first notes of the two
; scales, or their second notes, or third, etc.), if the scales
; are transposed so as to minimize that largest difference
(define (scale-difference s1 s2)
(let* ((intervals (map interval-1 s1 s2))
(interval-diffs (filter positive? (map2 interval-1 (sort intervals >)))))
(if (null? interval-diffs)
0
(/ (apply min interval-diffs) 2))))
; s1 and s2 are mod 1 and have the same length
; return least difference between any rotation of s1 and any rotation of s2
(define (least-scale-difference s1 s2)
(apply min (map (lambda (s) (scale-difference s1 s))
(all-rotations-1 s2))))
(define (min-scorers-w-score f lst)
(let* ((scored-lst (map (lambda (x) (cons (f x) x))
lst))
(min-score (foldl (lambda (x a) (min a (car x)))
(caar scored-lst) (cdr scored-lst))))
(filter (lambda (x) (equal? (car x) min-score))
scored-lst)))
; return a list of those items x of lst for which (f x) is least
(define (min-scorers f lst)
(map cdr (min-scorers-w-score f lst)))
; return a possibly-empty list of the nearest scales to scale
; each element of the return value has the form: (difference scale . scale-name)
(define (nearest-known-scales scale)
(let* ((len (length scale))
(scales (filter (lambda (s-n) (= len (length (cdar s-n))))
(hash->list known-scales))))
(if (null? scales)
'()
(let ((s (convert-to-mod-1 (cons modulus scale))))
(min-scorers-w-score (lambda (s-n)
(least-scale-difference s (convert-to-mod-1 (car s-n))))
scales)))))
(define (scale-name s)
(let ((ss (nearest-known-scales s))
(d (/ scale-tolerance 1200)))
(if (null? ss)
#f
(let ((diff (caar ss))
(name (cddar ss)))
(cond
((> diff d) #f)
((zero? diff) name)
(else (string-append name " [" (number->string (round (* diff 1200))) "]")))))))
; list of transpositions of scale where the first note,
; then the second, then the third, etc. becomes n
(define (all-transpositions-to m scale n)
(map (lambda (k) (transpose-scale m scale (- n k)))
scale))
(define (sort-numbers lst)
(sort lst <))
(define (all-transpositions scale)
(build-list modulus (lambda (i) (sort-numbers (transpose-scale modulus scale i)))))
(define (all-transformations scale)
(append (all-transpositions scale)
(all-transpositions (invert-scale modulus scale))))
; x and y are lists of numbers, each in increasing order
; is x a subset of y?
(define (subset? x y)
(cond
((null? x) #t)
((null? y) #f)
((< (car x) (car y)) #f)
((< (car y) (car x)) (subset? x (cdr y)))
(else (subset? (cdr x) (cdr y)))))
; x and y are lists of numbers, each in increasing order and containing no duplicates
; result satisfies the same conditions
(define (intersection x y)
(cond
((or (null? x) (null? y)) '())
((< (car x) (car y)) (intersection (cdr x) y))
((< (car y) (car x)) (intersection x (cdr y)))
(else (cons (car x) (intersection (cdr x) (cdr y))))))
; x and y are lists of numbers, each in increasing order and containing no duplicates
; result satisfies the same conditions
(define (set-difference x y)
(cond
((null? x) '())
((null? y) x)
((< (car x) (car y)) (cons (car x) (set-difference (cdr x) y)))
((< (car y) (car x)) (set-difference x (cdr y)))
(else (set-difference (cdr x) (cdr y)))))
; x and y are lists of numbers, each in increasing order and containing no duplicates
; result satisfies the same conditions
(define (symmetric-difference x y)
(cond
((null? x) y)
((null? y) x)
((< (car x) (car y)) (cons (car x) (symmetric-difference (cdr x) y)))
((< (car y) (car x)) (cons (car y) (symmetric-difference x (cdr y))))
(else (symmetric-difference (cdr x) (cdr y)))))
; x, y and common are lists of numbers, each in increasing order and containing no duplicates
(define (complement? x y common n)
(<= (length (set-difference (intersection x y) common))
n))
; first element of each scale is its modulus, rest are its notes.
; return the two scales after converting them to have the same modulus.
(define (convert-to-same-modulus scale-1 scale-2)
(let ((m1 (car scale-1))
(m2 (car scale-2)))
(let ((m3 (lcm m1 m2)))
(let ((k1 (/ m3 m1))
(k2 (/ m3 m2)))
(values (map (lambda (n) (* n k1))
scale-1)
(map (lambda (n) (* n k2))
scale-2))))))
; subset is in increasing order
; return a list of 3-element lists,
; each sublist consisting of (1) the subset,
; (2) the name of a superset, and (3) a list of modes
; of that superset. Each elements of (3) might be #f
; instead of a mode. A mode is a list of numbers.
(define (known-supersets subset)
(let ((subset1 (divide-by-gcd subset)))
(hash-map known-scales
(lambda (scale name)
(let-values (((subset2 scale2) (convert-to-same-modulus subset1 scale)))
(let ((notes (cdr subset2)))
(list subset2 name
(map (lambda (s)
(and (subset? notes (sort s <))
s))
(all-transpositions-to (car scale2) (cdr scale2) (car notes))))))))))
; first element of scale is the modulus, rest are the notes
(define (print-known-supersets scale)
(let* ((ss (known-supersets scale))
(ss2 (filter (lambda (x) (ormap values (third x)))
ss))
(ss3 (map (lambda (x) (list (first x) (second x) (filter values (third x))))
ss2)))
(if (null? ss3)
(display "given scale is not a subset of any known scale\n\n")
(for-each (lambda (x)
(let ((subset (first x))
(name (second x))
(modes (third x)))
(display "given scale, ")
(display (cdr subset))
(display " mod ")
(display (car subset))
(display ", is a subset of these modes of ")
(display name)
(display ":\n")
(for-each (lambda (mode)
(display " ")
(display mode)
(newline))
modes)
(newline)))
ss3))))
(define (preprocess-cell c)
(let* ((range (- (car c) 1))
(normal (cdr c))
(inverted (invert-scale modulus normal))
(len (- (length normal) 1)))
(list range len normal inverted)))
; extract the parts of a preprocessed cell
(define cell-range first)
(define cell-len second)
(define cell-normal third)
(define cell-inverted fourth)
(define (vector-increment! v i)
(vector-set! v i (+ 1 (vector-ref v i))))
; measures the extent to which letters are repeated
(define (repetitiveness x) ; x: list of name codes
(let ((v (make-vector 7 0)))
(for-each (lambda (c) (vector-increment! v (car c)))
x)
(apply + (map (lambda (x) (* x x))
(vector->list v)))))
; number of flats or number of sharps, whichever is smaller
(define (inconsistency x) ; x: list of name codes
(let ((v (make-vector 3 0)))
(for-each (lambda (c) (vector-increment! v (+ 1 (cadr c))))
x)
(min (vector-ref v 0)
(vector-ref v 2))))
(define (best-spellings scale)
(let* ((all-spellings (apply cartesian-product
(map (lambda (n) (vector-ref name-codes n))
scale)))
(best (min-scorers inconsistency
(min-scorers repetitiveness all-spellings))))
(map (lambda (scale) (map code->name scale))
best)))
(define (display-spellings s)
(let ((spellings (best-spellings s)))
(for-each (lambda (x) (display x) (newline))
(if multiple-spellings
spellings
(list (car spellings))))))
; return a list of lists, such that appending
; them all together yields lst, and such that,
; if p and q are any two elements of the same
; list, (f p) equals (f q)
;
; e.g.
; (split (lambda (n) (modulo n 10))
; '(1 11 21 22 12 0 1 2 5 25 15 35))
; yields ((1 11 21) (22 12) (0) (1) (2) (5 25 15 35))
(define (split f lst)
(if (null? lst)
'()
(let recur ((lst (cdr lst))
(a '()) ; list of lists
(b (list (car lst))) ; list
(x (f (car lst))))
(if (null? lst)
(reverse (cons (reverse b) a))
(let ((y (f (car lst))))
(if (equal? x y)
(recur (cdr lst) a (cons (car lst) b) y)
(recur (cdr lst) (cons (reverse b) a) (list (car lst)) y)))))))
; return a list of lists, each of which is of length n
; and the elements of which are taken, in order, from lst.
; the last list ends in enough elements equal to filler
; to bring its length up to n.
(define (split-n n lst filler)
(let recur ((lst lst)
(a '()) ; list of lists
(b '()) ; list
(k 0)) ; length of b
(cond
((= k n)
(recur lst (cons (reverse b) a) '() 0))
((and (null? lst) (zero? k))
(reverse a))
((null? lst)
(recur lst a (cons filler b) (+ 1 k)))
(else
(recur (cdr lst) a (cons (car lst) b) (+ 1 k))))))
(define (display-scale-numbers s)
(display s))
(define (display-scale-letters s)
(display (car (best-spellings (case modulus
((12) (map (lambda (n) (* n 2)) s))
((24) s))))))
(define (display-scale-intervals s)
(let ((x (notes->intervals s)))
(display (append x x))))
(define (display-scale-keyboard s)
(let ((n-keys (length keyboard-notes)))
(let recur ((s s)
(offset 0))
(when (pair? s)
(let* ((note (car s))
(key (+ (vector-ref keyboard note)
offset
(if (>= note first-note) 0 n-keys))))
(if (< key 12)
(begin (display key) (display " " ) (recur (cdr s) offset))
(begin (display "| ") (recur s (- offset 12)))))))))
(define (display-scale s quit)
(when please-stop
(newline)
(displayln "printing interrupted")
(quit))
(let ((name (scale-name s)))
(when name (displayln name)))
(display "notes: ")
(display-scale-numbers s)
(newline)
(display "intervals: ")
(display-scale-intervals s)
(newline)
(case modulus
((12) (display-spellings (map (lambda (n) (* n 2)) s)))
((24) (display-spellings s)))
(when (> modulus 12)
(display-scale-keyboard s)
(newline))
(display "number of wolves: ")
(display (count-all-wolves s))
(newline))
(define (display-scales ss)
(call/cc (lambda (c)
(for-each (lambda (s)
(display-scale s c)
(newline))
ss))))
(define (equalize-heights row)
(let ((height (apply max (map length row))))
(map (lambda (group)
(append group (build-list (- height (length group))
(lambda (n) ""))))
row)))
; scales: list of scales
(define (display-scales-columns scales)
(let* ((stringify (lambda (scale)
(with-output-to-string
(lambda ()
(let ((f (case output-format
(("numbers") display-scale-numbers)
(("letters") (if (member modulus '(12 24))
display-scale-letters
display-scale-numbers))
(("intervals") display-scale-intervals)
(("keyboard") display-scale-keyboard))))
(f scale))))))
; list of groups, each of which is a list of scales
(rotation-groups (split least-rotation-m scales))
; same, except with each scale converted to a string
; also, add name if it has one
(groups (map (lambda (group)
(let ((scale-strings (map stringify group))
(name (scale-name (car group))))
(if name (cons name scale-strings) scale-strings)))
rotation-groups))
; list of rows, each of which is a list of groups.
; the number of groups in each row is column-count.
; the groups of a row will be displayed left to right.
; rows will be displayed top to bottom.
(rows (split-n column-count groups '("")))
; list of column widths.
; each is the length of the longest string in that column.
(column-widths (if (null? rows)
'()
(apply map (lambda column (apply max (map string-length (flatten column))))
rows))))
(define (display-line strs)
(for-each (lambda (str width)
(display str)
(display (padding str width)))
strs
(map (lambda (n) (+ n 2)) column-widths)))
(define (display-row r)
(apply for-each (lambda line
(display-line line)
(newline))
(equalize-heights r)))
(for-each (lambda (r)
(display-row r)
(newline))
rows)))
(define (print-scales scales)
(let ((sorted-scales ((apply compose1 (map scale-sorter sort-order)) scales)))
(if multi-column
(display-scales-columns sorted-scales)
(display-scales sorted-scales))))
(define (display-note n)
(display n)
(case modulus
((12) (display " ") (display (vector-ref note-names (* n 2))))
((24) (display " ") (display (vector-ref note-names n)))))
(define (display-any x)
(cond
((number? x) (display-note x))
((and (pair? x) (pair? (car x))) (display-scales x))
((pair? x) (display-scale x))))
(define (display-now x)
(display x)
(flush-output))
(define found!
(let ((then (current-seconds)))
(lambda (s)
(set! found-scales (cons s found-scales))
(let ((now (current-seconds)))
(when (> now then)
(set! then now)
(display-now #\.))))))
; notes is a list of allowable notes, in increasing order
; notes-len is the length of notes
; scale is the scale so far, in decreasing order
; scale-len is the length of scale
; n-wolf is the number of wolf intervals in scale
; n-balance is the number of notes in scale that are in balance-notes
; n-bad-cell is the number of occurrences in scale of bad cells
; n-good-cell is the number of occurrences in scale of good cells
; n-bad-interval is the number of occurrences in scale of bad intervals
; n-good-interval is the number of occurrences in scale of good intervals
; call found! for every scale that follows the rules and
; which can be made by adding to 'scale' any number (> 0)
; of notes from 'notes'
(define (find-scales notes notes-len scale scale-len n-wolf n-balance n-bad-cell n-good-cell n-bad-interval n-good-interval)
(when (and (not please-stop)
(positive? notes-len)
(< scale-len length-max)
(>= (+ scale-len notes-len) length-min))
(let ((n (car notes))
(notes (cdr notes))
(notes-len (- notes-len 1)))
(when (not (member n required-notes))
(find-scales notes notes-len scale scale-len n-wolf n-balance n-bad-cell n-good-cell n-bad-interval n-good-interval))
(when (and (allowed-intervals-ok? n scale)
(distances-ok? n scale scale-len))
(let ((n-wolf (+ n-wolf (count-wolves n scale)))
(n-bad-cell (+ n-bad-cell (count-cells bad-cells n scale scale-len)))
(n-bad-interval (+ n-bad-interval (count-intervals bad-intervals n scale))))
(when (and (<= n-wolf wolf-max)
(<= n-bad-cell bad-cell-max)
(<= n-bad-interval bad-interval-max))
(let ((n-balance (+ n-balance (if (member n balance-notes) 1 0)))
(n-good-cell (+ n-good-cell (count-cells good-cells n scale scale-len)))
(n-good-interval (+ n-good-interval (count-intervals good-intervals n scale)))
(scale (cons n scale))
(scale-len (+ 1 scale-len)))
(find-scales notes notes-len scale scale-len n-wolf n-balance n-bad-cell n-good-cell n-bad-interval n-good-interval)
(when (and (>= scale-len length-min)
(>= n-wolf wolf-min)
(balance-ok? scale-len n-balance)
(contains-required-notes? scale)
(final-distances-ok? scale)
(final-allowed-intervals-ok? scale)
(<= (+ n-bad-cell (final-count-cells bad-cells scale scale-len))
bad-cell-max)
(>= (+ n-good-cell (final-count-cells good-cells scale scale-len))
good-cell-min)
(<= (+ n-bad-interval (final-count-intervals bad-intervals scale))
bad-interval-max)
(>= (+ n-good-interval (final-count-intervals good-intervals scale))
good-interval-min))
(found! (reverse scale))))))))))
(define (count-intervals intervals n scale)
(if (member (interval (car scale) n) intervals)
1
0))
(define (final-count-intervals intervals scale)
(count-intervals intervals first-note scale))
(define (contains-required-notes? scale)
(subset? required-notes (sort scale <)))
(define (distances-ok? n scale len)
(and (>= (interval (car scale) n) distance-2-min)
(or (<= len 1)
(and (>= (interval (cadr scale) n) distance-3-min)
(>= (interval n (list-ref scale (- len 2))) distance-3-min)))))
(define (final-distances-ok? scale)
(and (>= (interval (car scale) first-note) distance-2-min)
(>= (interval (cadr scale) first-note) distance-3-min)))
(define (allowed-intervals-ok? n scale)
(or (null? allowed-intervals)
(member (interval (car scale) n)
allowed-intervals)))
(define (final-allowed-intervals-ok? scale)
(or (null? allowed-intervals)
(and (member (interval (car scale) first-note)
allowed-intervals)
(if require-all-allowed-intervals
(let ((intervals (notes->intervals (reverse scale))))
(andmap (lambda (i) (member i intervals))
allowed-intervals))
#t))))
(define (count-cells-1 c note scale len)
(if (< len (cell-len c))
0
(let ((notes (sort-numbers (cons note (take scale (min len (cell-range c))))))
(cell-transpositions (map sort-numbers
(append (all-transpositions-to modulus (cell-normal c) note)
(all-transpositions-to modulus (cell-inverted c) note)))))
(count (lambda (ct) (subset? ct notes))
cell-transpositions))))
(define (count-cells cells note scale len)
(apply + (map (lambda (c) (count-cells-1 c note scale len))
cells)))
(define (final-count-cells-1 c ss len)
(let ((r (min (cell-range c) (- len 1))))
(let recur ((s (list-tail ss (- len r)))
(i r))
(if (<= i 0)
0
(+ (count-cells-1 c (car s) (cdr s) (- len 1))
(recur (cdr s) (- i 1)))))))
(define (final-count-cells cells scale len)
(let ((ss (append scale scale)))
(apply + (map (lambda (c) (final-count-cells-1 c ss len))
cells))))
(define (count-wolves n scale)
(foldl (lambda (note sum)
(+ sum
(if (member (interval note n) wolves) 1 0)
(if (member (interval n note) wolves) 1 0)))
0 scale))
(define (balance-ok? scale-len n-balance)
(<= balance-in-min n-balance (- scale-len balance-out-min)))
(define (count-all-wolves scale)
(if (null? scale)
0
(+ (count-wolves (car scale) (cdr scale))
(count-all-wolves (cdr scale)))))
(define (count-balance-out scale)
(apply + (map (lambda (note) (if (member note balance-notes) 0 1))
scale)))
(define (least-distance-3 s)
(let ((t (append (cddr s) (list (car s) (cadr s)))))
(apply min (map interval s t))))
; r is a pair of numbers, and represents
; the half-open interval between them
(define (in-range x r)
(and (<= (car r) x) (< x (cdr r))))
; does a precede b in the scale?
; it's more complicated than simply (< a b)
; because the scale starts at first-note and
; goes up to modulus, then wraps around to 0
; and continues up to first-note.
(define (note-comparer)
(let ((p (cons first-note modulus))
(q (cons 0 first-note)))
(lambda (a b)
(cond
((and (in-range a p) (in-range b q)) #t)
((and (in-range b p) (in-range a q)) #f)
(else (< a b))))))
; list of scales, each of which is 'scale' plus one allowed note
(define (with-extra-note scale)
(map (lambda (n) (sort (cons n scale) (note-comparer)))
allowed-notes))
(define (scale-complete? scale ss)
(not (ormap (lambda (s)
(set-member? ss s))
(with-extra-note scale))))
(define (remove-incompletes scales)
(let ((ss (list->set scales)))
(filter (lambda (s)
(scale-complete? s ss))
scales)))
(define (make-keyboard)
(let ((v (make-vector modulus 'bug)))
(let recur ((notes keyboard-notes)
(key 0))
(when (pair? notes)
(vector-set! v (car notes) key)
(recur (cdr notes) (+ 1 key))))
v))
(define (initialize-keyboard no-keyboard)
(when no-keyboard
(set! first-note 0))
(set! keyboard-notes (if (or no-keyboard (null? keyboard-notes-raw))
(build-list modulus values)
keyboard-notes-raw))
(set! keyboard (make-keyboard)))
(define (generate)
(copy-settings-from-gui-to-vars)
(initialize-keyboard #f)
(set! first-note (modulo first-note modulus))
(set! required-notes (sort required-notes <))
(display-settings 1)
(display-now "finding scales...")
(set! allowed-notes (filter (lambda (n) (and (member n keyboard-notes)
(not (member n forbidden-notes))))
(build-list (- modulus 1)
(lambda (n) (modulo (+ first-note 1 n) modulus)))))
(set! good-cells (map preprocess-cell good-cells-raw))
(set! bad-cells (map preprocess-cell bad-cells-raw))
(set! found-scales '())
(find-scales allowed-notes (length allowed-notes) (list first-note) 1
0 (if (member first-note balance-notes) 1 0) 0 0 0 0)
(if please-stop
(displayln "interrupted")
(begin
(displayln "done")
(when require-completeness
(display-now "removing incomplete scales...")
(set! found-scales (remove-incompletes found-scales))
(displayln "done"))))
(newline)
(let ((n-scale (length found-scales)))
(display "number of scales found: ")
(displayln n-scale)
(newline)
(set! please-stop #f)
(print-scales (if (<= n-scale scales-max)
found-scales
(random-sample found-scales scales-max #:replacement? #f)))))
; scales is a list of pairs, each of which is (modulus-prefixed-list-of-notes . name)
(define (list-scales scales)
(let* ((ss (sort scales (comparer <) #:key car))
(notes-list (map (lambda (scale)
(with-output-to-string
(lambda () (display (car scale)))))
ss))
(name-list (map cdr ss))
(len (+ 1 (apply max (map string-length notes-list)))))
(for-each (lambda (notes name)
(display notes)
(display (padding notes len))
(displayln name))
notes-list
name-list)
(newline)))
(define (print-identification m s)
(let ((t (if reorder-notes (sort-numbers s) s)))
(if display-supersets
(print-known-supersets (cons m t))
(print-scales (all-rotations m t)))))
; scale is a modulus-prefixed list of notes
(define (identify-scale scale)
(let ((m (car scale))
(s (cdr scale)))
(set! modulus m) ; yuck
(initialize-keyboard #t)
(display-settings 2)
(print-identification m s)))
(define (convert-to-list str)
(nest-appropriately str 'list))
(define (identify)
(copy-settings-from-gui-to-vars)
(case scale-interpretation
(("notes") (identify-scale (cons modulus (convert-to-list scale-contents2))))
(("intervals") (identify-scale (intervals->notes (convert-to-list scale-contents2))))
(("name") (let* ((name (string-foldcase scale-contents2))
(scales (filter (lambda (s) (string-contains? (string-foldcase (cdr s)) name))
(hash->list known-scales))))
(cond
((null? scales) (display "no scale contains '")
(display name)
(displayln "' in its name")
(newline))
((null? (cdr scales)) (identify-scale (caar scales)))
(else (let ((exact-matches (filter (lambda (s) (string-ci=? (cdr s) name))
scales)))
(if (null? exact-matches)
(list-scales scales)
(identify-scale (caar exact-matches))))))))))
(define (list-known-scales)
(list-scales (hash->list known-scales)))
(define (display-complements-from f scales)
(print-scales
(remove-duplicates
(filter (lambda (s)
(complement? s scale-contents3 common-notes max-additional-common-notes))
(apply append (map f scales))))))
(define (complement)
(copy-settings-from-gui-to-vars)
(initialize-keyboard #t)
(set! common-notes (sort common-notes <))
(set! scale-contents3 (sort scale-contents3 <))
(display-settings 3)
(case complement-source
(("the scale above") (display-complements-from all-transformations (list scale-contents3)))
(("all named scales") (display-complements-from all-transpositions
(map cdr (filter (lambda (s) (= modulus (car s)))
(hash-keys known-scales)))))))
; optional name (a string), then modulus, then notes
(define mapping-table-list
'(
("row 9" 12 0 3 11 2 10 8 5 1 4 9 6 7)
("row 8" 12 0 3 6 2 9 4 5 11 10 8 1 7)
("row 7" 12 0 2 8 11 7 3 4 10 9 6 1 5)
("row 6" 12 0 1 8 10 7 5 2 9 11 6 3 4)
("row 5" 12 0 10 6 9 5 2 11 8 7 4 1 3)
("row 4" 12 0 8 5 7 4 1 10 6 9 3 11 2)
("row 3" 12 0 9 2 6 4 10 11 5 7 3 8 1)
("row 2" 12 0 6 3 5 2 11 8 4 7 1 9 10)
("row 1" 12 0 4 1 3 8 11 5 2 9 7 10 6)
("mof8" 12 0 4 11 6 8 2 3 5 7 10 1 9)
("mof7" 12 0 4 11 5 8 1 3 10 7 9 6 2)
("mof6A" 12 0 4 10 5 8 1 2 11 6 9 7 3)
("mof6B" 12 0 4 9 6 8 2 1 11 5 10 7 3)
("mof5" 12 0 4 7 5 8 1 11 6 3 9 2 10)
("mof4A" 12 0 4 7 2 8 10 11 5 3 6 1 9)
("mof4B" 12 0 4 7 2 8 10 11 1 3 6 9 5)
("mof3" 12 0 4 6 3 8 11 10 5 2 7 1 9)
("mof2A" 12 0 4 1 10 8 6 5 11 9 2 7 3)
("mof2B" 12 0 4 1 10 8 6 5 3 9 2 11 7)
(171
0 148 125 102 79 56 33 10 158 135 112 89
66 43 20 168 145 122 99 76 53 30 7 155
132 109 86 63 40 17 165 142 119 96 73 50
27 4 152 129 106 83 60 37 14 162 139 116
93 70 47 24 1 149 126 103 80 57 34 11
159 136 113 90 67 44 21 169 146 123 100 77)
(171
0 147 123 99 75 51 27 3 150 126 102 78
54 30 6 153 129 105 81 57 33 9 156 132
108 84 60 36 12 159 135 111 87 63 39 15
162 138 114 90 66 42 18 165 141 117 93 69
45 21 168 144 120 96 72 48 24 0 147 123
99 75 51 27 3 150 126 102 78 54 30 6)
(171
0 146 121 96 71 46 21 167 142 117 92 67
42 17 163 138 113 88 63 38 13 159 134 109
84 59 34 9 155 130 105 80 55 30 5 151
126 101 76 51 26 1 147 122 97 72 47 22
168 143 118 93 68 43 18 164 139 114 89 64
39 14 160 135 110 85 60 35 10 156 131 106)
(171
0 144 117 90 63 36 9 153 126 99 72 45
18 162 135 108 81 54 27 0 144 117 90 63
36 9 153 126 99 72 45 18 162 135 108 81
54 27 0 144 117 90 63 36 9 153 126 99
72 45 18 162 135 108 81 54 27 0 144 117
90 63 36 9 153 126 99 72 45 18 162 135)
(171
0 142 113 84 55 26 168 139 110 81 52 23
165 136 107 78 49 20 162 133 104 75 46 17
159 130 101 72 43 14 156 127 98 69 40 11
153 124 95 66 37 8 150 121 92 63 34 5
147 118 89 60 31 2 144 115 86 57 28 170
141 112 83 54 25 167 138 109 80 51 22 164)
(171
0 141 111 81 51 21 162 132 102 72 42 12
153 123 93 63 33 3 144 114 84 54 24 165
135 105 75 45 15 156 126 96 66 36 6 147
117 87 57 27 168 138 108 78 48 18 159 129
99 69 39 9 150 120 90 60 30 0 141 111
81 51 21 162 132 102 72 42 12 153 123 93)
(171
0 136 101 66 31 167 132 97 62 27 163 128
93 58 23 159 124 89 54 19 155 120 85 50
15 151 116 81 46 11 147 112 77 42 7 143
108 73 38 3 139 104 69 34 170 135 100 65
30 166 131 96 61 26 162 127 92 57 22 158
123 88 53 18 154 119 84 49 14 150 115 80)
(171
0 131 91 51 11 142 102 62 22 153 113 73
33 164 124 84 44 4 135 95 55 15 146 106
66 26 157 117 77 37 168 128 88 48 8 139
99 59 19 150 110 70 30 161 121 81 41 1
132 92 52 12 143 103 63 23 154 114 74 34
165 125 85 45 5 136 96 56 16 147 107 67)
(171
0 121 71 21 142 92 42 163 113 63 13 134
84 34 155 105 55 5 126 76 26 147 97 47
168 118 68 18 139 89 39 160 110 60 10 131
81 31 152 102 52 2 123 73 23 144 94 44
165 115 65 15 136 86 36 157 107 57 7 128
78 28 149 99 49 170 120 70 20 141 91 41)
(171
0 120 69 18 138 87 36 156 105 54 3 123
72 21 141 90 39 159 108 57 6 126 75 24
144 93 42 162 111 60 9 129 78 27 147 96
45 165 114 63 12 132 81 30 150 99 48 168
117 66 15 135 84 33 153 102 51 0 120 69
18 138 87 36 156 105 54 3 123 72 21 141)
(171
0 102 33 135 66 168 99 30 132 63 165 96
27 129 60 162 93 24 126 57 159 90 21 123
54 156 87 18 120 51 153 84 15 117 48 150
81 12 114 45 147 78 9 111 42 144 75 6
108 39 141 72 3 105 36 138 69 0 102 33
135 66 168 99 30 132 63 165 96 27 129 60)
(171
0 101 31 132 62 163 93 23 124 54 155 85
15 116 46 147 77 7 108 38 139 70 0 101
31 132 62 163 93 23 124 54 155 85 15 116
46 147 77 7 108 38 139 70 0 101 31 132
62 163 93 23 124 54 155 85 15 116 46 147
77 7 108 38 139 70 0 101 31 132 62 163)
(171
0 100 30 130 60 160 90 19 120 49 150 79
9 109 39 139 70 0 100 30 130 60 160 90
19 120 49 150 79 9 109 39 139 70 0 100
30 130 60 160 90 19 120 49 150 79 9 109
39 139 70 0 100 30 130 60 160 90 19 120
49 150 79 9 109 39 139 70 0 100 30 130)
(171
0 101 29 130 60 159 89 19 118 48 149 77
7 108 36 137 67 166 96 26 125 55 156 84
14 115 43 144 74 2 103 33 132 62 163 91
21 122 50 151 81 9 110 40 139 70 0 101
29 130 60 159 89 19 118 48 149 77 7 108
36 137 67 166 96 26 125 55 156 84 14 115)
(171
0 100 29 129 58 158 87 16 116 45 145 74
3 103 32 132 61 161 90 19 119 48 148 77
6 106 35 135 64 164 93 22 122 51 151 80
9 109 38 138 67 167 96 25 125 54 154 83
12 112 41 141 70 0 100 29 129 58 158 87
6 116 45 145 74 3 103 32 132 61 161 90)
(171
0 100 28 128 57 157 86 15 114 43 143 71
0 100 28 128 57 157 86 15 114 43 143 71
0 100 28 128 57 157 86 15 114 43 143 71
0 100 28 128 57 157 86 15 114 43 143 71
0 100 28 128 57 157 86 15 114 43 143 71
0 100 28 128 57 157 86 15 114 43 143 71)
(171
0 99 27 126 54 153 81 9 108 36 135 63
162 90 18 117 45 144 72 0 99 27 126 54
153 81 9 108 36 135 63 162 90 18 117 45
144 72 0 99 27 126 54 153 81 9 108 36
135 63 162 90 18 117 45 144 72 0 99 27
126 54 153 81 9 108 36 135 63 162 90 18)
(171
0 97 23 120 46 143 69 166 92 18 115 41
138 64 161 87 13 110 36 133 59 156 82 8
105 31 128 54 151 77 3 100 26 123 49 146
72 169 95 21 118 44 141 67 164 90 16 113
39 136 62 159 85 11 108 34 131 57 154 80
6 103 29 126 52 149 75 0 97 23 120 46)
(171
0 90 9 99 18 108 27 117 36 126 45 135
54 144 63 153 72 162 81 0 90 9 99 18
108 27 117 36 126 45 135 54 144 63 153 72
162 81 0 90 9 99 18 108 27 117 36 126
45 135 54 144 63 153 72 162 81 0 90 9
99 18 108 27 117 36 126 45 135 54 144 63)
(171
0 72 144 45 117 18 90 162 63 135 36 108
9 81 153 54 126 27 99 0 72 144 45 117
18 90 162 63 135 36 108 9 81 153 54 126
27 99 0 72 144 45 117 18 90 162 63 135
36 108 9 81 153 54 126 27 99 0 72 144
45 117 18 90 162 63 135 36 108 9 81 153)
(171
0 66 132 27 93 159 54 120 15 81 147 42
108 3 69 135 30 96 162 57 123 18 84 150
45 111 6 72 138 33 99 165 60 126 21 87
153 48 114 9 75 141 36 102 168 63 129 24
90 156 51 117 12 78 144 39 105 0 66 132
27 93 159 54 120 15 81 147 42 108 3 69)
(171
0 51 102 153 33 84 135 15 66 117 168 48
99 150 30 81 132 12 63 114 165 45 96 147
27 78 129 9 60 111 162 42 93 144 24 75
126 6 57 108 159 39 90 141 21 72 123 3
54 105 156 36 87 138 18 69 120 0 51 102
153 33 84 135 15 66 117 168 48 99 150 30)
(171
0 50 100 150 29 79 129 8 58 108 158 37
87 137 16 66 116 166 45 95 145 24 74 124
3 53 103 153 32 82 132 11 61 111 161 40
90 140 19 69 119 169 48 98 148 27 77 127
6 56 106 156 35 85 135 14 64 114 164 43
93 143 22 72 122 1 51 101 151 30 80 130)
(171
0 40 80 120 160 29 69 109 149 18 58 98
138 7 47 87 127 167 36 76 116 156 25 65
105 145 14 54 94 134 3 43 83 123 163 32
72 112 152 21 61 101 141 10 50 90 130 170
39 79 119 159 28 68 108 148 17 57 97 137
6 46 86 126 166 35 75 115 155 24 64 104)
(171
0 35 70 105 140 4 39 74 109 144 8 43
78 113 148 12 47 82 117 152 16 51 86 121
156 20 55 90 125 160 24 59 94 129 164 28
63 98 133 168 32 67 102 137 1 36 71 106
141 5 40 75 110 145 9 44 79 114 149 13
48 83 118 153 17 52 87 122 157 21 56 91)
(171
0 25 50 75 100 125 150 4 29 54 79 104
129 154 8 33 58 83 108 133 158 12 37 62
87 112 137 162 16 41 66 91 116 141 166 20
45 70 95 120 145 170 24 49 74 99 124 149
3 28 53 78 103 128 153 7 32 57 82 107
132 157 11 36 61 86 111 136 161 15 40 65)
(171
0 24 48 72 96 120 144 168 21 45 69 93
117 141 165 18 42 66 90 114 138 162 15 39
63 87 111 135 159 12 36 60 84 108 132 156
9 33 57 81 105 129 153 6 30 54 78 102
126 150 3 27 51 75 99 123 147 0 24 48
72 96 120 144 168 21 45 69 93 117 141 165)
(171
0 23 46 69 92 115 138 161 13 36 59 82
105 128 151 3 26 49 72 95 118 141 164 16
39 62 85 108 131 154 6 29 52 75 98 121
144 167 19 42 65 88 111 134 157 9 32 55
78 101 124 147 170 22 45 68 91 114 137 160
12 35 58 81 104 127 150 2 25 48 71 94)
))
(define (common-prefix-len xs ys)
(if (and (pair? xs)
(pair? ys)
(equal? (car xs) (car ys)))
(+ 1 (common-prefix-len (cdr xs) (cdr ys)))
0))
(define (make-name t len)
(with-output-to-string
(lambda ()
(display "[")
(if (string? (car t))
(display (car t))
(for-each display (add-between (take t len) " ")))
(display "]"))))
(define (interleave xs ys)
(cond
((null? xs) ys)
((null? ys) xs)
(else (cons (car xs)
(cons (car ys)
(interleave (cdr xs) (cdr ys)))))))
(define make-named-table cons)
(define table-name car)
(define table-vector cdr)
; vector of named-tables
; the table-vector of each contains mod-1 notes
(define mapping-tables
(apply vector
(let* ((nameless (filter (lambda (x) (not (string? (car x)))) mapping-table-list))
(name-len (if (< (length nameless) 2)
3
(+ 1 (apply max (map2 common-prefix-len (sort nameless (comparer <)))))))
(names (map (lambda (t) (make-name t name-len))
mapping-table-list))
(named-tables (map (lambda (name table)
(make-named-table name (apply vector (convert-to-mod-1 (if (string? (car table))
(cdr table)
table)))))
names mapping-table-list)))
(for-each (lambda (name)
(send (hash-ref gui-fields 'from-table) append name)
(send (hash-ref gui-fields 'to-table) append name))
names)
named-tables)))
(define (cycle-table n)
(make-named-table n (apply vector (convert-to-mod-1 (cons modulus (build-list modulus (lambda (k) (mod (* k n) modulus))))))))
(define (distance a b)
(min (interval-1 a b)
(interval-1 b a)))
; index in vector v of note nearest to n
; among the first len elements of v
(define (pos-in-vector n v len)
(let recur ((i 0)
(p #f)
(min-d 1))
(if (>= i len)
p
(let ((d (distance n (vector-ref v i))))
(if (< d min-d)
(recur (+ 1 i) i d)
(recur (+ 1 i) p min-d))))))
(define (map-between-vectors note v1 v2)
(round (* modulus (vector-ref v2 (pos-in-vector (/ note modulus) v1 (min (vector-length v1) (vector-length v2)))))))
(define (map-between-tables notes t1 t2)
(cons (table-name t1)
(cons (table-name t2)
(map (lambda (n)
(map-between-vectors n (table-vector t1) (table-vector t2)))
notes))))
(define (arithmetic-series lo (hi lo) (step 1))
(if (> lo hi)
'()
(cons lo (arithmetic-series (+ lo step) hi step))))
(define (compute-tables cycle table)
(if (null? table)
(map cycle-table (apply arithmetic-series cycle))
(map (lambda (n) (vector-ref mapping-tables n)) table)))
(define (all-mappings notes)
(map (lambda (args)
(apply map-between-tables notes args))
(cartesian-product (compute-tables from-cycle from-table)
(compute-tables to-cycle to-table))))
(define (display-motif m)
(display (car m))
(display "->")
(display (cadr m))
(display ": ")
(display (cddr m))
(newline))
(define (boulez-multiply xs ys swap-args)
(let ((xs (if swap-args ys xs))
(ys (if swap-args xs ys)))
(map (lambda (y+x)
(apply transpose-note modulus y+x))
(cartesian-product ys xs))))
(define (mapbc-then-multiply multiplier swap-args)
(map (lambda (mapped-motif)
(cons (car mapped-motif)
(cons (cadr mapped-motif)
(boulez-multiply (cddr mapped-motif) multiplier swap-args))))
(all-mappings motif)))
(define (multiply-then-mapbc multiplier swap-args)
(all-mappings (boulez-multiply motif multiplier swap-args)))
(define (mapbc-and-multiply multiplier swap-args)
((if (equal? mm-order "map, then multiply")
mapbc-then-multiply
multiply-then-mapbc)
multiplier swap-args))
(define (mmm)
(copy-settings-from-gui-to-vars)
(initialize-keyboard #t)
(display-settings 4)
(let* ((multiplier (if multiplier-special
(build-list (third multiplier)
(lambda (n)
(+ (first multiplier) (* n (second multiplier)))))
multiplier))
(results 'whatever)
(p (lambda (b)
(set! results (mapbc-and-multiply multiplier b))
(for-each display-motif results))))
(when (member multiplicand-order '("motif times multiplier" "both"))
(p #f))
(when (equal? multiplicand-order "both")
(newline))
(when (member multiplicand-order '("multiplier times motif" "both"))
(p #t))
(when identify-results
(newline)
(newline)
(for-each (lambda (result)
(display-motif result)
(newline)
(print-identification modulus (cddr result))
(newline))
results))))
(define (positions->spacing positions)
((if wrap-spacing map2 map2a)
(lambda (a b) (modulo (- b a) spacing-row-length))
positions))
; row is a list of distinct notes
; return a function which, given any element of row,
; returns the position where it occurs in row
(define (position-func row)
(let ((v (make-vector modulus)))
(let recur ((row row)
(n 0))
(when (pair? row)
(vector-set! v (car row) n)
(recur (cdr row) (+ 1 n))))
(lambda (x) (vector-ref v x))))
; spacing of xs in ys
(define (spacing xs ys)
(positions->spacing (map (position-func ys) xs)))
; row is a list of notes, not necessarily distinct
; return a function which, given any element of row,
; returns a list of the positions where it occurs in row
(define (position-list-func row)
(let ((v (make-vector modulus '())))
(let recur ((row row)
(n 0))
(when (pair? row)
(vector-set! v (car row) (cons n (vector-ref v (car row))))
(recur (cdr row) (+ 1 n))))
(lambda (x) (vector-ref v x))))
; list of spacings of xs in ys
; each spacing is a list of numbers
(define (spacings xs ys)
(map positions->spacing
(apply cartesian-product
(map (position-list-func ys) xs))))
(define (spacing-ok? sp)
(and (<= spacing-error-min
(count (lambda (x) (not (<= spacing-min x spacing-max)))
sp)
spacing-error-max)
(<= 1-space-min
(count (lambda (x) (= x 1))
sp)
1-space-max)))
(define (some-spacing-ok? xs ys)
(if (= modulus row-length)
(spacing-ok? (spacing xs ys)) ; this is just a speed optimization
(ormap spacing-ok? (spacings xs ys)))) ; this would work correctly in all cases
(define (transpositions row)
(build-list modulus (lambda (i) (transpose-scale modulus row i))))
; same as (append (reverse a) b), but faster
(define (append-r a b)
(if (null? a)
b
(append-r (cdr a) (cons (car a) b))))
; same as (append-r (map f lst) lst), but faster
(define (append-r-map f lst)
(let recur ((lst lst)
(result lst))
(if (null? lst)
result
(recur (cdr lst) (cons (f (car lst)) result)))))
(define (standard-transformations row)
(append-r-map reverse
(append-r-map invert-scale-m
(transpositions row))))
(define (multiply-note n x)
(modulo (* n x) modulus))
(define (multiply-row r x)
(map (lambda (n) (multiply-note n x))
r))
(define (motif-ok? row)
(let ((motif (take row motif-length))
(ok? (lambda (xformed-motif) (some-spacing-ok? xformed-motif row))))
(>= (+ (if standard-transforms (count ok? (standard-transformations motif )) 0)
(if 5m-transforms (count ok? (standard-transformations (multiply-row motif 5))) 0))
motif-min)))
; return a list of lists, each of which is the
; same as lst except that one of its elements
; (a different one for each sublist) has been
; moved to the front, with the other elements
; appearing in the same order as in lst
(define (move-each-to-front lst)
(let recur ((a '())
(b lst)
(r '()))
(if (null? b)
r
(recur
(cons (car b) a)
(cdr b)
(cons (cons (car b) (append-r a (cdr b)))
r)))))
; call f (for side-effects only) on certain permutations,
; each of length n, of elements taken from lst
; every permutation starts with (car lst)
; if n is greater than the length of lst, in each permutation
; all elements of lst are used before any is repeated
; the permutations are constructed one element at a time,
; and ok? can return #f to indicate that we should bail
; out early, if it determines that no permutations that
; start a certain way should be passed to f
; ok? uses data to help make its decision, and it returns
; new data which will be passed into subsequent calls to it
(define (call-with-permutations lst n f ok? final-ok? data)
(let recur ((perm (list (car lst))) ; initial part of permutation constructed so far, in reverse
(n (- n 1)) ; number of elements that still need to be added to perm
(xs (cdr lst)) ; list of possibilities for the next element
(data data)) ; summary data computed by ok? based on perm
(if (zero? n)
(let ((fwd-perm (reverse perm)))
(when (apply final-ok? fwd-perm perm data)
(f fwd-perm)))
(for-each (lambda (y)
(let ((new-data (apply ok? (car y) perm data)))
(when new-data
(recur (cons (car y) perm) (- n 1) (cdr y) new-data))))
(move-each-to-front (if (null? xs) lst xs))))))
(define (partial-row-ok? note row row-len n-bad-cell n-good-cell n-bad-interval n-good-interval last-interval n-interval)
(let ((i (interval (car row) note)))
(let ((n-interval (if (= last-interval i) (+ 1 n-interval) 1))
(last-interval i)
(n-bad-interval (+ n-bad-interval (count-intervals mof-bad-intervals note row)))
(n-good-interval (+ n-good-interval (count-intervals mof-good-intervals note row)))
(n-bad-cell (+ n-bad-cell (count-cells mof-bad-cells note row row-len)))
(n-good-cell (+ n-good-cell (count-cells mof-good-cells note row row-len)))
(row-len (+ 1 row-len)))
(and (not please-stop)
(<= n-interval interval-repetition-max)
(<= n-bad-interval mof-bad-interval-max)
(<= n-bad-cell mof-bad-cell-max)
(list row-len n-bad-cell n-good-cell n-bad-interval n-good-interval last-interval n-interval)))))
; number of initial elements of list xs that are equal to x
(define (run-length x xs)
(let recur ((xs xs)
(n 0))
(if (or (null? xs)
(not (equal? x (car xs))))
n
(recur (cdr xs) (+ 1 n)))))
(define (final-row-ok? fwd-row row row-len n-bad-cell n-good-cell n-bad-interval n-good-interval last-interval n-interval)
(and (>= (+ n-good-cell (if wrap-row (final-count-cells mof-good-cells row row-len) 0))
mof-good-cell-min)
(>= (+ n-good-interval (if wrap-row (final-count-intervals mof-good-intervals row) 0))
mof-good-interval-min)
(let ((intervals ((if wrap-row map2 map2a) interval fwd-row)))
(and (>= (length (remove-duplicates intervals))
distinct-interval-min)
(or (not wrap-row)
(and (<= (+ n-bad-cell (final-count-cells mof-bad-cells row row-len))
mof-bad-cell-max)
(<= (+ n-bad-interval (final-count-intervals mof-bad-intervals row))
mof-bad-interval-max)
(<= (let* ((i (interval (car row) (car fwd-row)))
(rl (+ 1 (run-length i intervals))))
(min row-len
(if (= i last-interval)
(+ n-interval rl)
rl)))
interval-repetition-max)))))))
(define initial-data '(1 0 0 0 0 -1 0))
; call f on row if row passes the tests specified
; by functions ok? and final-ok?, which work the
; same as those passed to call-with-permutations
(define (call-with-row row f ok? final-ok? data)
(let recur ((rr (list (car row)))
(r (cdr row))
(data data))
(if (null? r)
(when (apply final-ok? row rr data)
(f row))
(let ((new-data (apply ok? (car r) rr data)))
(when new-data
(recur (cons (car r) rr) (cdr r) new-data))))))
; x and y are lists of equal length
; return the number of positions at which x and y differ
(define (hamming-distance x y)
(let recur ((x x)
(y y)
(n 0))
(cond ((null? x) n)
((equal? (car x) (car y)) (recur (cdr x) (cdr y) n))
(else (recur (cdr x) (cdr y) (+ 1 n))))))
(define (near? d x y)
(<= (hamming-distance x y) d))
(define (near-any? d x ys)
(ormap (lambda (y) (near? d x y))
ys))
(define (self-eq? same x y)
(define (na? a b)
(near-any? self-eq-tolerance a b))
(or (na? x (if same (cdr (all-rotations-m y)) (all-rotations-m y)))
(na? x (all-rotations-m (reverse y)))
(na? x (all-rotations-m (invert-scale-m y)))
(na? x (all-rotations-m (reverse (invert-scale-m y))))))
(define (self-equivalent? row)
(or (and self-eq-standard (self-eq? #t row row))
(and self-eq-5m (self-eq? #f row (multiply-row row 5)))))
(define (process-row! row)
(when (and (motif-ok? row)
(not (self-equivalent? row)))
(found! row)))
(define (rotation-transformations row)
(let ((inverted-row (invert-scale-m row)))
(append (all-rotations-m row)
(all-rotations-m (reverse row))
(all-rotations-m inverted-row)
(all-rotations-m (reverse inverted-row)))))
(define (remove-near-duplicates rows)
(let recur ((processed '())
(unprocessed (map rotation-transformations rows)))
(if (or please-stop (null? unprocessed))
(map car (append unprocessed processed))
(let ((row (caar unprocessed)))
(if (ormap (lambda (ys) (near-any? duplicate-tolerance row ys))
processed)
(recur processed (cdr unprocessed))
(recur (cons (car unprocessed) processed) (cdr unprocessed)))))))
(define mof-bad-cells '())
(define mof-good-cells '())
(define settings-in-use '())
(define loaded-results '())
(define loaded-results-path "")
(define (mof)
(copy-settings-from-gui-to-vars)
(set! settings-in-use (get-data-from-gui))
(initialize-keyboard #t)
(display-settings 5)
(display-now "finding rows...")
(set! mof-bad-cells (map preprocess-cell mof-bad-cells-raw))
(set! mof-good-cells (map preprocess-cell mof-good-cells-raw))
(set! found-scales '())
(if (equal? results-file "")
(begin
(set! loaded-results '())
(set! loaded-results-path "")
(call-with-permutations (build-list modulus values) row-length
process-row! partial-row-ok? final-row-ok? initial-data))
(let ((path (normalize-results-path results-file)))
(when (not (equal? path loaded-results-path))
(read-results results-file #f))
(call/cc
(lambda (quit)
(for-each (lambda (result)
(if please-stop
(quit)
(call-with-row result process-row! partial-row-ok? final-row-ok? initial-data)))
loaded-results)))
(set! found-scales (reverse found-scales))))
(displayln (if please-stop "interrupted" "done"))
(newline)
(let ((n-row (length found-scales)))
(display "number of rows found: ")
(displayln n-row)
(newline)
(when filter-duplicates
(display-now "removing near-duplicates...")
(set! please-stop #f)
(set! found-scales (remove-near-duplicates found-scales))
(displayln (if please-stop "interrupted" "done"))
(newline)
(set! n-row (length found-scales))
(display "number of rows remaining: ")
(displayln n-row)
(newline))
(set! please-stop #f)
(print-scales (if (<= n-row rows-max)
found-scales
(random-sample found-scales rows-max #:replacement? #f)))))
(define mallalieu '(0 1 4 2 9 5 11 3 8 10 7 6))
(define (repeat n f)
(when (> n 0)
(f)
(repeat (- n 1) f)))
(define test-x 0)
(define (test)
(set! test-x 0)
(call-with-permutations
(lambda (p) (when (motif-ok? p) (set! test-x (+ 1 test-x))))
(lambda args '())
(lambda args '())
12
'(0 1 2 3 4 5 6 7 8 9 10 11)
'()))
(send the-frame show #t)
[/PLAIN]
