Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

more fixes to literal rhythm, more tests

  • Loading branch information...
commit b8653230855f03622ac5a58a3bb95a575db19e0f 1 parent 30023ae
k7f authored
26 work/om/rhythm/rhythm-tests.factor
... ... @@ -1,9 +1,33 @@
1 1 ! Copyright (C) 2012 krzYszcz.
2 2 ! See http://factorcode.org/license.txt for BSD license.
3 3
4   -USING: accessors kernel math om.rhythm tools.test ;
  4 +USING: accessors arrays eval io.streams.string kernel macros math om.rhythm
  5 + prettyprint sequences tools.test ;
5 6 IN: om.rhythm.tests
6 7
  8 +: parse-unparse-literal ( token vocabs -- token' obj )
  9 + " " join "USING: " " ; " surround prepend
  10 + ( -- obj ) eval
  11 + [ [ pprint ] with-string-writer ] keep ;
  12 +
  13 +: reparse-literal ( token vocabs -- obj ? )
  14 + over [ parse-unparse-literal swap ] dip = ;
  15 +
  16 +[
  17 + { { {< >} t } { {< >} f } { {< >} f }
  18 + { {< -2 >} t } { {< 1 >} t } { {< 2 >} t } { {< 3//4 >} t }
  19 + { {< >} f } { {< 2 >< >} t } { {< 3//4 >} f }
  20 + { {< >} f } { {< -2 >} f } { {< 1 >} f } { {< 2 >} f }
  21 + }
  22 +] [
  23 + { "{< >}" "{< >< >}" "{< -1 >}"
  24 + "{< -2 >}" "{< 1 >}" "{< 2 >}" "{< 3//4 >}"
  25 + "{< 1 >< >}" "{< 2 >< >}" "{< 3//4 >< >}"
  26 + "{< >< -1 >}" "{< >< -2 >}" "{< >< 1 >}" "{< >< 2 >}"
  27 + }
  28 + [ { "om.rhythm" } reparse-literal 2array ] map
  29 +] unit-test
  30 +
7 31 [ {< 1/4 1/4 1/4 1/4 >} 1 ] [
8 32 t { 1/4 1/4 1/4 1/4 } <rhythm-tree> dup duration>>
9 33 ] unit-test
42 work/om/rhythm/rhythm.factor
@@ -454,19 +454,17 @@ SYMBOLS: (SEE) (SEP) (DIV) ;
454 454 : (parse-state?) ( obj -- ? )
455 455 { (SEE) (SEP) (DIV) } member? ; inline
456 456
457   -: (parse-left-brace) ( -- relt/* state' )
  457 +: (parse-left-brace) ( -- relt/* )
458 458 V{ } clone \ {< execute-parsing ?first
459   - [ "inner syntax" invalid-input ] unless* (DIV) ; inline
  459 + [ "inner syntax" invalid-input ] unless* ; inline
460 460
461   -: (parse-separator) ( state -- relt/* state' )
462   - dup (DIV) = [
463   - drop "unexpected \"><\"" invalid-input
464   - ] when (DIV) ; inline
  461 +: (?keep-state) ( state -- state/* )
  462 + dup (DIV) = [ drop "unexpected \"><\"" invalid-input ] when ; inline
465 463
466 464 : (element-or-meter) ( token -- relt/dur/* state )
467 465 {
468   - { [ dup "{<" = ] [ drop (parse-left-brace) ] }
469   - { [ dup "><" = ] [ drop t (DIV) ] }
  466 + { [ dup "{<" = ] [ drop (parse-left-brace) (DIV) ] }
  467 + { [ dup "><" = ] [ drop (SEP) (DIV) ] }
470 468 { [ dup "f" = ] [ drop f (SEP) ] }
471 469 { [ dup "t" = ] [ drop t (SEP) ] }
472 470 [ dup string>number [ nip (SEE) ] [ >meter (SEP) ] if* ]
@@ -475,20 +473,27 @@ SYMBOLS: (SEE) (SEP) (DIV) ;
475 473 : (element-or-error) ( state token -- state' relt/* )
476 474 {
477 475 { [ dup "{<" = ] [ 2drop (parse-left-brace) ] }
478   - { [ dup "><" = ] [ drop (parse-separator) ] }
479   - [ nip dup string>number [ nip ] [ invalid-input ] if* (DIV) ]
480   - } cond swap ; inline
  476 + { [ dup "><" = ] [ drop (?keep-state) ] }
  477 + [ nip dup string>number [ nip ] [ invalid-input ] if* ]
  478 + } cond (DIV) swap ; inline
481 479
482   -: (empty-postprocess) ( car -- car' cdr )
483   - dup meter? [ -1 ] [ 1 swap ] if 1array ; inline
  480 +: (empty-tail) ( car -- car' cdr )
  481 + {
  482 + { [ dup meter? ] [ -1 ] }
  483 + { [ dup (parse-state?) ] [ drop 1 -1 ] }
  484 + [ 1 swap ]
  485 + } cond 1array ; inline
  486 +
  487 +: (empty-head) ( car -- car' ) drop 1 ; inline
  488 +
  489 +: (deferred-tail) ( cdr -- cdr' ) rest [ -1 1array ] when-empty ; inline
484 490
485 491 : (parse-postprocess) ( car cdr -- car' cdr' )
486   - [ (empty-postprocess) ] [
487   - dup first (parse-state?) [
488   - rest [ -1 1array ] when-empty
489   - ] [
  492 + [ (empty-tail) ] [
  493 + dup first (parse-state?) [ (deferred-tail) ] [
490 494 over rhythm-element? [ swap prefix 1 swap ] when
491 495 ] if
  496 + [ dup (parse-state?) [ (empty-head) ] when ] dip
492 497 ] if-empty ;
493 498
494 499 : (parse-rhythm) ( accum -- accum )
@@ -533,8 +538,7 @@ SYNTAX: {< (parse-rhythm) ;
533 538
534 539 : (pprint-division) ( rtree -- )
535 540 division>> dup (pprint-unit-rest?)
536   - [ drop -1 pprint* ]
537   - [ pprint-elements ] if ;
  541 + [ drop ] [ pprint-elements ] if ;
538 542 PRIVATE>
539 543
540 544 M: rhythm-tree pprint* ( rtree -- )

0 comments on commit b865323

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