Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

more fixes to literal rhythm, more tests

  • Loading branch information...
commit b8653230855f03622ac5a58a3bb95a575db19e0f 1 parent 30023ae
@k7f authored
Showing with 48 additions and 20 deletions.
  1. +25 −1 work/om/rhythm/rhythm-tests.factor
  2. +23 −19 work/om/rhythm/rhythm.factor
View
26 work/om/rhythm/rhythm-tests.factor
@@ -1,9 +1,33 @@
! Copyright (C) 2012 krzYszcz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math om.rhythm tools.test ;
+USING: accessors arrays eval io.streams.string kernel macros math om.rhythm
+ prettyprint sequences tools.test ;
IN: om.rhythm.tests
+: parse-unparse-literal ( token vocabs -- token' obj )
+ " " join "USING: " " ; " surround prepend
+ ( -- obj ) eval
+ [ [ pprint ] with-string-writer ] keep ;
+
+: reparse-literal ( token vocabs -- obj ? )
+ over [ parse-unparse-literal swap ] dip = ;
+
+[
+ { { {< >} t } { {< >} f } { {< >} f }
+ { {< -2 >} t } { {< 1 >} t } { {< 2 >} t } { {< 3//4 >} t }
+ { {< >} f } { {< 2 >< >} t } { {< 3//4 >} f }
+ { {< >} f } { {< -2 >} f } { {< 1 >} f } { {< 2 >} f }
+ }
+] [
+ { "{< >}" "{< >< >}" "{< -1 >}"
+ "{< -2 >}" "{< 1 >}" "{< 2 >}" "{< 3//4 >}"
+ "{< 1 >< >}" "{< 2 >< >}" "{< 3//4 >< >}"
+ "{< >< -1 >}" "{< >< -2 >}" "{< >< 1 >}" "{< >< 2 >}"
+ }
+ [ { "om.rhythm" } reparse-literal 2array ] map
+] unit-test
+
[ {< 1/4 1/4 1/4 1/4 >} 1 ] [
t { 1/4 1/4 1/4 1/4 } <rhythm-tree> dup duration>>
] unit-test
View
42 work/om/rhythm/rhythm.factor
@@ -454,19 +454,17 @@ SYMBOLS: (SEE) (SEP) (DIV) ;
: (parse-state?) ( obj -- ? )
{ (SEE) (SEP) (DIV) } member? ; inline
-: (parse-left-brace) ( -- relt/* state' )
+: (parse-left-brace) ( -- relt/* )
V{ } clone \ {< execute-parsing ?first
- [ "inner syntax" invalid-input ] unless* (DIV) ; inline
+ [ "inner syntax" invalid-input ] unless* ; inline
-: (parse-separator) ( state -- relt/* state' )
- dup (DIV) = [
- drop "unexpected \"><\"" invalid-input
- ] when (DIV) ; inline
+: (?keep-state) ( state -- state/* )
+ dup (DIV) = [ drop "unexpected \"><\"" invalid-input ] when ; inline
: (element-or-meter) ( token -- relt/dur/* state )
{
- { [ dup "{<" = ] [ drop (parse-left-brace) ] }
- { [ dup "><" = ] [ drop t (DIV) ] }
+ { [ dup "{<" = ] [ drop (parse-left-brace) (DIV) ] }
+ { [ dup "><" = ] [ drop (SEP) (DIV) ] }
{ [ dup "f" = ] [ drop f (SEP) ] }
{ [ dup "t" = ] [ drop t (SEP) ] }
[ dup string>number [ nip (SEE) ] [ >meter (SEP) ] if* ]
@@ -475,20 +473,27 @@ SYMBOLS: (SEE) (SEP) (DIV) ;
: (element-or-error) ( state token -- state' relt/* )
{
{ [ dup "{<" = ] [ 2drop (parse-left-brace) ] }
- { [ dup "><" = ] [ drop (parse-separator) ] }
- [ nip dup string>number [ nip ] [ invalid-input ] if* (DIV) ]
- } cond swap ; inline
+ { [ dup "><" = ] [ drop (?keep-state) ] }
+ [ nip dup string>number [ nip ] [ invalid-input ] if* ]
+ } cond (DIV) swap ; inline
-: (empty-postprocess) ( car -- car' cdr )
- dup meter? [ -1 ] [ 1 swap ] if 1array ; inline
+: (empty-tail) ( car -- car' cdr )
+ {
+ { [ dup meter? ] [ -1 ] }
+ { [ dup (parse-state?) ] [ drop 1 -1 ] }
+ [ 1 swap ]
+ } cond 1array ; inline
+
+: (empty-head) ( car -- car' ) drop 1 ; inline
+
+: (deferred-tail) ( cdr -- cdr' ) rest [ -1 1array ] when-empty ; inline
: (parse-postprocess) ( car cdr -- car' cdr' )
- [ (empty-postprocess) ] [
- dup first (parse-state?) [
- rest [ -1 1array ] when-empty
- ] [
+ [ (empty-tail) ] [
+ dup first (parse-state?) [ (deferred-tail) ] [
over rhythm-element? [ swap prefix 1 swap ] when
] if
+ [ dup (parse-state?) [ (empty-head) ] when ] dip
] if-empty ;
: (parse-rhythm) ( accum -- accum )
@@ -533,8 +538,7 @@ SYNTAX: {< (parse-rhythm) ;
: (pprint-division) ( rtree -- )
division>> dup (pprint-unit-rest?)
- [ drop -1 pprint* ]
- [ pprint-elements ] if ;
+ [ drop ] [ pprint-elements ] if ;
PRIVATE>
M: rhythm-tree pprint* ( rtree -- )

0 comments on commit b865323

Please sign in to comment.
Something went wrong with that request. Please try again.