Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also .

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also .
...
  • 3 commits
  • 4 files changed
  • 0 commit comments
  • 1 contributor
View
8 work/addenda/eval/eval.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2012 krzYszcz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: eval sequences ;
+IN: addenda.eval
+
+: eval-using ( token vocabs -- obj )
+ " " join "USING: " " ; " surround prepend ( -- obj ) eval ;
View
60 work/addenda/prettyprint/prettyprint.factor
@@ -0,0 +1,60 @@
+! Copyright (C) 2012 krzYszcz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: assocs classes combinators io io.streams.string kernel math.parser
+ prettyprint.backend prettyprint.custom prettyprint.sections sequences
+ strings vectors ;
+IN: addenda.prettyprint
+
+GENERIC: deep-pprint* ( obj -- )
+
+M: object deep-pprint* pprint* ;
+
+: deep-pprint-elements ( seq -- )
+ do-length-limit
+ [ [ deep-pprint* ] each ] dip
+ [ number>string "~" " more~" surround text ] when* ;
+
+M: sequence deep-pprint* ( obj -- )
+ [
+ <flow
+ dup pprint-delims [
+ pprint-word
+ dup pprint-narrow? <inset
+ >pprint-sequence deep-pprint-elements
+ block>
+ ] dip pprint-word block>
+ ] check-recursion ;
+
+: deep-pprint-slot-value ( name value -- )
+ <flow \ { pprint-word
+ [ text ] [ f <inset deep-pprint* block> ] bi*
+ \ } pprint-word block> ;
+
+: (deep-pprint-tuple) ( opener class slots closer -- )
+ <flow {
+ [ pprint-word ]
+ [ pprint-word ]
+ [ t <inset [ deep-pprint-slot-value ] assoc-each block> ]
+ [ pprint-word ]
+ } spread block> ;
+
+: deep-pprint-tuple ( tuple -- )
+ [
+ [ \ T{ ] dip [ class-of ] [ tuple>assoc ] bi
+ \ } (deep-pprint-tuple)
+ ] ?pprint-tuple ;
+
+M: tuple deep-pprint* deep-pprint-tuple ;
+
+: .tuple ( tuple -- ) [ deep-pprint-tuple ] with-pprint nl ;
+
+: unparse-tuple ( tuple -- string )
+ [ .tuple ] with-string-writer
+ dup length <vector> [
+ dup CHAR: \n = [ drop CHAR: space ] when
+ dup CHAR: space = [
+ over ?last CHAR: space = [ drop ] [ suffix! ] if
+ ] [ suffix! ] if
+ ] reduce
+ dup last CHAR: space = [ but-last-slice ] when >string ;
View
32 work/om/rhythm/rhythm-tests.factor
@@ -1,9 +1,39 @@
! Copyright (C) 2012 krzYszcz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math om.rhythm tools.test ;
+USING: accessors addenda.eval addenda.prettyprint arrays io.streams.string
+ kernel math om.rhythm prettyprint sequences tools.test ;
IN: om.rhythm.tests
+[
+ "T{ rhythm-tree { duration 1 } { division { T{ rhythm-tree { duration 1 } { division { -1 } } } } } }"
+] [
+ {< {< >} >} unparse-tuple
+] unit-test
+
+: (reparse-literal) ( token vocabs -- obj token' )
+ eval-using [ [ pprint ] with-string-writer ] keep swap ; inline
+
+: reparse-literal ( token vocabs -- obj ? )
+ over [ (reparse-literal) ] 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 }
+ { {< {< >} >} t }
+ }
+] [
+ { "{< >}" "{< >< >}" "{< -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 -- )

No commit comments for this range

Something went wrong with that request. Please try again.