Skip to content

Extend pattern language #375

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
pdcawley wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Extend pattern language #375

Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
1dcb0e6
Add support for 0-argument lambdas as notes
pdcawley Feb 16, 2020
9161107
Extend the pattern language to allow for dotted and shortened notes
pdcawley Feb 21, 2020
ce61f0f
Remove a stray debugging `println`
pdcawley Feb 22, 2020
f223164
Make | work compound notes
pdcawley Feb 22, 2020
3cc5d43
Merge branch 'master' into extend-pattern-language
pdcawley May 13, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
249 changes: 213 additions & 36 deletions libs/core/pattern-language.xtm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,122 @@
lst
(append (cdr lst) '(0))))))

(define pattern_atom_duration
(lambda (atm)
(cond ((eq? '| atm) 1)
((eq? '+ atm) 1/2)
((eq? '- atm) -1/2)
(else 1))))

(define rmap_pattern_length
(lambda (lst)
(apply + (map pattern_atom_duration lst))))

(define (modify_duration_by dur lst)
(let ((modifiers (take-while is_modifier? lst)))
(foldl (lambda (d m)
(cond ((eq? '| m) (+ d dur))
((eq? '+ m) (* 3/2 d))
((eq? '- m) (* 1/2 d))))
dur modifiers)))

(define skip_leading_modifiers
(lambda (lists)
(map (lambda (l) (drop-while is_modifier? l))
lists)))


(define pattern_special_atoms '(_ | + -))
(define pattern_modifiers '(+ - |))


(define is_special?
(lambda (atom) (member atom pattern_special_atoms)))

(define is_modifier?
(lambda (atom) (member atom pattern_modifiers)))

(define count_specials
(lambda (lst t char)
(length (take-while (lambda (x) (equal? x char))
(cl:nthcdr (min (cdr t)
(length lst))
lst)))))

(define event_locations
(lambda (base-duration lst)
(let loop ((res '())
(l lst)
(list-pos 1)
(total-dur 0))
(if (null? l) (reverse res)
(let* ((evt (car l))
(modifiers (take-while is_modifier? (cdr l)))
(next-l-pos (+ 1 (length modifiers)))
(duration (modify_duration_by base-duration modifiers))
(elapsed (+ total-dur duration)))
(loop (cons (cons total-dur (cons duration list-pos)) res)
(cl:nthcdr next-l-pos l)
(+ list-pos next-l-pos)
elapsed))))))

(define count_specials
(lambda (lst t char)
(length (take-while (lambda (x) (equal? x char))
(cl:nthcdr (min (cdr t)
(length lst))
lst)))))


(define evaluate_event
(lambda (evt)
(cond ((vector? evt) (map (lambda (x) (eval x (interaction-environment)))
(vector->list l)))
((and (symbol? evt) (not (is_special? evt)))
(let ((ll (eval evt (interaction-environment))))
(if (procedure? ll)
(eval `(,ll) (interaction-environment))
(else ll))))
evt)))


(define make_tmpargs
(lambda (t args)
(map (lambda (l)
(if (list? l)
(set! l (rmap_helper_lst_sym_transform l))
(if (pair? l)
(set! l ((eval (cdr l)) (rmap_helper_lst_sym_transform (car l))))
(set! l (list l))))
(if (< (length l) (cddr t))
(list-ref l (modulo (- (cddr t) 1) (length l)))
(list-ref l (- (cddr t) 1))))
args)))

(define make_targs
(lambda (tmpargs)
(reverse
(foldl (lambda (acc l)
(cond
((vector? l) (cons (map (lambda (x) (eval x)) (vector->list l)) acc))
((and (symbol? l) (not (is_special? l)))
(let ((ll (eval l (interaction-environment))))
(cons (cond
((procedure? ll)
(eval `(,ll) (interaction-environment)))
(else
ll))
acc)))
(else (cons l acc))))
'() tmpargs))))

(define is_position_between?
(lambda (startpos endpos)
(lambda (pos-cell)
(let ((pos (car pos-cell)))
(and (>= pos startpos)
(< pos endpos))))))

(define rmap_helper
(lambda (beats offset func beat dur loopcnt looppos . args)
(let* ((lst (rmap_helper_lst_sym_transform (if (list? (car args))
Expand All @@ -31,47 +147,25 @@
(caar args)
'(_ _ _ _)))))
(pos (modulo (- looppos offset) beats)) ;;(modulo (- beat offset) beats))
(one_beat (/ beats (length lst)))
(lst_positions (range 0 (+ pos beats) one_beat))
(one_beat (/ beats (rmap_pattern_length lst)))
(nextpos (+ pos dur))
(idx 0)
(f (lambda (old new)
(set! idx (+ idx 1))
(if (and (>= new pos) (< new nextpos))
(cons (cons new idx) old)
old)))
(newlst (foldl f '() lst_positions)))
(newlst (filter (is_position_between? pos nextpos)
(event_locations one_beat lst))))

(map (lambda (t)
(let* ((tmpargs (map (lambda (l)
(if (list? l)
(set! l (rmap_helper_lst_sym_transform l))
(if (pair? l)
(set! l ((eval (cdr l)) (rmap_helper_lst_sym_transform (car l))))
(set! l (list l))))
(if (< (length l) (cdr t))
(list-ref l (modulo (- (cdr t) 1) (length l)))
(list-ref l (- (cdr t) 1))))
args))
(targs (map (lambda (l)
(cond ((vector? l) (map (lambda (x) (eval x)) (vector->list l)))
((and (symbol? l) (not (member l '(_ |)))) (eval l))
(else l)))
tmpargs)))
(let* ((tmpargs (make_tmpargs t args))
(targs (make_targs tmpargs))
(current-dur (cadr t))
)
(cond
((or (list? (car tmpargs)) (pair? (car tmpargs)))
(apply rmap_helper one_beat offset func (+ beat (- (car t) pos)) one_beat loopcnt (+ looppos (- (car t) pos)) targs))
((member (car tmpargs) '(_ |)) #f) ;; skip these symbols
(apply rmap_helper current-dur offset func (+ beat (- (car t) pos)) current-dur loopcnt (+ looppos (- (car t) pos)) targs))
((member (car tmpargs) pattern_special_atoms) #f) ;; skip these symbols
(else
;; this is a messy expression, but it just counts the number of
;; '| symbols *after* the current value, and adds them to the
;; duration
(let ((note-dur (* one_beat
(+ 1 (length (take-while (lambda (x) (equal? x '|))
(cl:nthcdr (min (cdr t) (length (car args))) (car args))))))))
(apply callback
(- (*metro* (+ beat (- (car t) pos))) *RMAP_HELPER_CALLBACK_OFFSET*)
func (+ beat (- (car t) pos)) note-dur
loopcnt targs))))))
(apply callback
(- (*metro* (+ beat (- (car t) pos))) *RMAP_HELPER_CALLBACK_OFFSET*)
func (+ beat (- (car t) pos)) current-dur
loopcnt targs)))))
newlst))))

;; rhythm map
Expand Down Expand Up @@ -260,6 +354,81 @@
(list a x)))
(if (list? a) a b)))))

;; Some .abc style note functions. The plain names are quantised to the
;; current *scale* by rmap_helper. Capitalised note names are in octave 3,
;; lowercase names in octave 4. In full .abc lower or higher octaves can be
;; specified by tacking , or ' respectively onto the low/high note names, but
;; I'm lazy.

;; Quantised notes
(define (a) (qnt a4))
(define (b) (qnt b4))
(define (c) (qnt c4))
(define (d) (qnt d4))
(define (e) (qnt e4))
(define (f) (qnt f4))
(define (g) (qnt g4))

(define (A) (qnt a3))
(define (B) (qnt b3))
(define (C) (qnt c3))
(define (D) (qnt d3))
(define (E) (qnt e3))
(define (F) (qnt f3))
(define (G) (qnt g3))

;; sharpened notes; these aren't quantised
(define (^a) a#4)
(define (^b) b#4)
(define (^c) c#4)
(define (^d) d#4)
(define (^e) e#4)
(define (^f) f#4)
(define (^g) g#4)

(define (^A) a#3)
(define (^B) b#3)
(define (^C) c#3)
(define (^D) d#3)
(define (^E) e#3)
(define (^F) f#3)
(define (^G) g#3)

;; flattened notes. Not quantised
(define (_a) ab4)
(define (_b) bb4)
(define (_c) cb4)
(define (_d) db4)
(define (_e) eb4)
(define (_f) fb4)
(define (_g) gb4)

(define (_A) ab3)
(define (_B) bb3)
(define (_C) cb3)
(define (_D) db3)
(define (_E) eb3)
(define (_F) fb3)
(define (_G) gb3)

;; Naturals, again not quantised
(define (=a) a3)
(define (=b) b3)
(define (=c) c3)
(define (=d) d3)
(define (=e) e3)
(define (=f) f3)
(define (=g) g3)

(define (=A) a4)
(define (=B) b4)
(define (=C) c4)
(define (=D) d4)
(define (=E) e4)
(define (=F) f4)
(define (=G) g4)


;; euclidean rhythms
;; written by Ben in recursive Scheme; Kernighan's aphorism probably applies

Expand Down Expand Up @@ -320,6 +489,14 @@
((pred (car remaining)) (loop (cons (car remaining) ret) (cdr remaining)))
(else (reverse ret))))))

(define drop-while
(lambda (pred lst)
(let loop ((ret lst))
(cond ((null? ret))
((pred (car ret)) (loop (cdr ret)))
(else ret)))))


;; skip by m with a lst rotation of r
;; for example: (skip 2 -1 (scale 3 8))
(define skip
Expand Down