From 8b351b1ad6e2355d97d20ef97822b470892bd0f2 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 7 Jan 2009 23:13:04 -0600 Subject: [PATCH 01/14] Fixing normalize errors --- basis/unicode/data/data.factor | 10 +++----- basis/unicode/normalize/normalize-docs.factor | 8 +------ .../unicode/normalize/normalize-tests.factor | 2 +- basis/unicode/normalize/normalize.factor | 23 ++++++++++--------- 4 files changed, 17 insertions(+), 26 deletions(-) diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 3e19c5c30d..8f99b6c160 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -28,10 +28,6 @@ VALUE: properties : char>name ( char -- string ) name-map value-at ; : property? ( char property -- ? ) properties at interval-key? ; -! Convenience functions -: ?between? ( n/f from to -- ? ) - pick [ between? ] [ 3drop f ] if ; - ! Loading data from UnicodeData.txt : split-; ( line -- array ) @@ -206,9 +202,9 @@ SYMBOL: interned : expand-ranges ( assoc -- interval-map ) [ [ - CHAR: . pick member? [ - swap ".." split1 [ hex> ] bi@ 2array - ] [ swap hex> ] if range, + swap CHAR: . over member? [ + ".." split1 [ hex> ] bi@ 2array + ] [ hex> ] if range, ] assoc-each ] { } make ; diff --git a/basis/unicode/normalize/normalize-docs.factor b/basis/unicode/normalize/normalize-docs.factor index 423332fb6e..65f50ab0ae 100644 --- a/basis/unicode/normalize/normalize-docs.factor +++ b/basis/unicode/normalize/normalize-docs.factor @@ -8,9 +8,7 @@ ARTICLE: "unicode.normalize" "Unicode normalization" { $subsection nfc } { $subsection nfd } { $subsection nfkc } -{ $subsection nfkd } -"If two strings in a normalization form are appended, the result may not be in that normalization form still. To append two strings in NFD and make sure the result is in NFD, the following procedure is supplied:" -{ $subsection string-append } ; +{ $subsection nfkd } ; HELP: nfc { $values { "string" string } { "nfc" "a string in NFC" } } @@ -27,7 +25,3 @@ HELP: nfkc HELP: nfkd { $values { "string" string } { "nfc" "a string in NFKD" } } { $description "Converts a string to Normalization Form KD" } ; - -HELP: string-append -{ $values { "s1" "a string in NFD" } { "s2" "a string in NFD" } { "string" "a string in NFD" } } -{ $description "Appends two strings, putting the result in NFD." } ; diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index 9662389531..25d5ce365c 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -1,6 +1,6 @@ USING: unicode.normalize kernel tools.test sequences unicode.data io.encodings.utf8 io.files splitting math.parser -locals math quotations assocs combinators ; +locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index eacdb2724a..f13eb07594 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -1,21 +1,24 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces make unicode.data kernel math arrays -locals sorting.insertion accessors assocs ; +locals sorting.insertion accessors assocs math.order ; IN: unicode.normalize [ compatibility-entry ] decompose ; : string-append ( s1 s2 -- string ) - ! This could be more optimized, - ! but in practice, it'll almost always just be append [ append ] keep 0 over ?nth non-starter? [ length dupd reorder-back ] [ drop ] if ; From 26711da67511098754000256ede12c16e87157ed Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:13:18 -0600 Subject: [PATCH 02/14] L-system: Key gestures for strafing camera. Support for changing turtle values. --- extra/L-system/L-system.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/L-system/L-system.factor b/extra/L-system/L-system.factor index 9b8bdc1914..5bc7ce1db6 100644 --- a/extra/L-system/L-system.factor +++ b/extra/L-system/L-system.factor @@ -256,7 +256,9 @@ DEFER: default-L-parser-values ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! TUPLE: < gadget - camera display-list pedestal paused commands axiom rules string ; + camera display-list pedestal paused + turtle-values + commands axiom rules string ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -376,6 +378,7 @@ TUPLE: < gadget L-SYSTEM display-list>> GL_COMPILE glNewList turtle + L-SYSTEM turtle-values>> [ ] or call L-SYSTEM string>> L-SYSTEM axiom>> or L-SYSTEM commands>> interpret-string @@ -445,6 +448,11 @@ H{ { T{ key-down f f "q" } [ [ 5 roll-left ] with-camera ] } { T{ key-down f f "w" } [ [ 5 roll-right ] with-camera ] } + { T{ key-down f { A+ } "LEFT" } [ [ 1 strafe-left ] with-camera ] } + { T{ key-down f { A+ } "RIGHT" } [ [ 1 strafe-right ] with-camera ] } + { T{ key-down f { A+ } "UP" } [ [ 1 strafe-up ] with-camera ] } + { T{ key-down f { A+ } "DOWN" } [ [ 1 strafe-down ] with-camera ] } + { T{ key-down f f "r" } [ start-rotation-thread ] } { From 07da37ffc8cb0f3e354dd910407705aedf1b75f4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:14:32 -0600 Subject: [PATCH 03/14] L-system.models.abop-2: change default angle --- extra/L-system/models/abop-2/abop-2.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/L-system/models/abop-2/abop-2.factor b/extra/L-system/models/abop-2/abop-2.factor index 2ed8f64abe..1168780300 100644 --- a/extra/L-system/models/abop-2/abop-2.factor +++ b/extra/L-system/models/abop-2/abop-2.factor @@ -9,20 +9,23 @@ IN: L-system.models.abop-2 L-parser-dialect >>commands + [ 30 >>angle ] >>turtle-values + "c(12)FAL" >>axiom { - { "A" "F[&'(.7)!BL]>(137)[&'(.6)!BL]>(137)'(.9)!(.9)A" } - { "B" "F[-'(.7)!(.9)$CL]'(.9)!(.9)C" } - { "C" "F[+'(.7)!(.9)$BL]'(.9)!(.9)B" } + { "A" "F [&'(.7)!BL] >(137) [&'(.6)!BL] >(137) '(.9) !(.9) A" } + + { "B" "F [- '(.7) !(.9) $ C L] '(.9) !(.9) C" } + { "C" "F [+ '(.7) !(.9) $ B L] '(.9) !(.9) B" } { "L" "~c(8){+f(.1)-f(.1)-f(.1)+|+f(.1)-f(.1)-f(.1)}" } } >>rules ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : main ( -- ) [ L-system abop-2 "L-system" open-window ] with-ui ; MAIN: main - \ No newline at end of file From 7c3576c4bb81af720f2315014b069603fb77caa6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:15:04 -0600 Subject: [PATCH 04/14] L-system.models.abop-3: change default angle --- extra/L-system/models/abop-3/abop-3.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/L-system/models/abop-3/abop-3.factor b/extra/L-system/models/abop-3/abop-3.factor index 49a63eb074..f594cafcd3 100644 --- a/extra/L-system/models/abop-3/abop-3.factor +++ b/extra/L-system/models/abop-3/abop-3.factor @@ -9,6 +9,8 @@ IN: L-system.models.abop-3 L-parser-dialect >>commands + [ 30 >>angle ] >>turtle-values + "c(12)FA" >>axiom { From a976830ff1836cdc1bf1dc7600561008ed3de7c3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:15:30 -0600 Subject: [PATCH 05/14] L-system.models.abop-4: change default angle --- extra/L-system/models/abop-4/abop-4.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/L-system/models/abop-4/abop-4.factor b/extra/L-system/models/abop-4/abop-4.factor index 6b2688a478..71cf32d4d7 100644 --- a/extra/L-system/models/abop-4/abop-4.factor +++ b/extra/L-system/models/abop-4/abop-4.factor @@ -9,6 +9,8 @@ IN: L-system.models.abop-4 L-parser-dialect >>commands + [ 18 >>angle ] >>turtle-values + "c(12)&(20)N" >>axiom { From 87e49f19a3be49611854d675388f188ecfac03b5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:15:47 -0600 Subject: [PATCH 06/14] L-system.models.abop-5: change default angle --- extra/L-system/models/abop-5/abop-5.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/L-system/models/abop-5/abop-5.factor b/extra/L-system/models/abop-5/abop-5.factor index abc346946a..5d6576f33a 100644 --- a/extra/L-system/models/abop-5/abop-5.factor +++ b/extra/L-system/models/abop-5/abop-5.factor @@ -9,6 +9,8 @@ IN: L-system.models.abop-5 L-parser-dialect >>commands + [ 5 >>angle ] >>turtle-values + "&(90)+(90)a" >>axiom { From fa73d98c288f25608832af9fce6c554935d46302 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:16:09 -0600 Subject: [PATCH 07/14] Add L-system.models.abop-6 --- extra/L-system/models/abop-6/abop-6.factor | 34 ++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 extra/L-system/models/abop-6/abop-6.factor diff --git a/extra/L-system/models/abop-6/abop-6.factor b/extra/L-system/models/abop-6/abop-6.factor new file mode 100644 index 0000000000..0639d53274 --- /dev/null +++ b/extra/L-system/models/abop-6/abop-6.factor @@ -0,0 +1,34 @@ + +USING: accessors ui L-system ; + +IN: L-system.models.abop-6 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: abop-6 ( -- ) + + L-parser-dialect >>commands + + [ 5 >>angle ] >>turtle-values + + ! "&(90)+(90)FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" + "FFF[-(120)'(.6)x][-(60)'(.8)x][+(120)'(.6)x][+(60)'(.8)x]x" + >>axiom + + { + { "a" "F[cdx][cex]F!(.9)a" } + { "x" "a" } + + { "d" "+d" } + { "e" "-e" } + + { "F" "'(1.25)F'(.8)" } + } + >>rules ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: main ( -- ) [ L-system abop-6 "L-system" open-window ] with-ui ; + +MAIN: main + \ No newline at end of file From 3a996c1afc7956c86ea782aa497d6870b57aa575 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:16:34 -0600 Subject: [PATCH 08/14] Add L-system.models.abop-5-angular --- .../abop-5-angular/abop-5-angular.factor | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/L-system/models/abop-5-angular/abop-5-angular.factor diff --git a/extra/L-system/models/abop-5-angular/abop-5-angular.factor b/extra/L-system/models/abop-5-angular/abop-5-angular.factor new file mode 100644 index 0000000000..29b1c72cbc --- /dev/null +++ b/extra/L-system/models/abop-5-angular/abop-5-angular.factor @@ -0,0 +1,33 @@ + +USING: accessors ui L-system ; + +IN: L-system.models.abop-5-angular + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: abop-5-angular ( -- ) + + L-parser-dialect >>commands + + "&(90)+(90)a" >>axiom + + { + { "a" "F[+(45)l][-(45)l]^;ca" } + + { "l" "j" } + { "j" "h" } + { "h" "s" } + { "s" "d" } + { "d" "x" } + { "x" "a" } + + { "F" "'(1.17)F'(.855)" } + } + >>rules ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: main ( -- ) [ L-system abop-5-angular "L-system" open-window ] with-ui ; + +MAIN: main + \ No newline at end of file From 09097ee2e676f509302b3afad0b5efef7a4a0470 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:17:57 -0600 Subject: [PATCH 09/14] update.latest: Move back to using 'git' protocol instead of 'http' (factorcode.org git daemon seems stable again) --- extra/update/latest/latest.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor index 98d264d227..77cd184cdb 100644 --- a/extra/update/latest/latest.factor +++ b/extra/update/latest/latest.factor @@ -7,7 +7,7 @@ IN: update.latest : git-pull-master ( -- ) image parent-directory [ - { "git" "pull" "http://factorcode.org/git/factor.git" "master" } + { "git" "pull" "git://factorcode.org/git/factor.git" "master" } run-command ] with-directory ; From 8c7e46283f04314568a60c26c2a68cfc0eb14f51 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:23:32 -0600 Subject: [PATCH 10/14] L-system.models.abop-5: Adjust axiom (grow along Z) --- extra/L-system/models/abop-5/abop-5.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/L-system/models/abop-5/abop-5.factor b/extra/L-system/models/abop-5/abop-5.factor index 5d6576f33a..2e373f713c 100644 --- a/extra/L-system/models/abop-5/abop-5.factor +++ b/extra/L-system/models/abop-5/abop-5.factor @@ -11,7 +11,7 @@ IN: L-system.models.abop-5 [ 5 >>angle ] >>turtle-values - "&(90)+(90)a" >>axiom + "a" >>axiom { { "a" "F[+(45)l][-(45)l]^;ca" } From 1aa0684d4580d5caece99e0d0b38dc5ee2629485 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 7 Jan 2009 23:54:19 -0600 Subject: [PATCH 11/14] Case conversion title case fixed --- basis/unicode/breaks/breaks.factor | 13 +++---- basis/unicode/case/case-tests.factor | 2 +- basis/unicode/case/case.factor | 35 +++++++++++-------- .../unicode/collation/collation-tests.factor | 4 +-- basis/unicode/normalize/normalize.factor | 6 ++-- 5 files changed, 31 insertions(+), 29 deletions(-) diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index b85e8879e1..1d2f821750 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -3,7 +3,7 @@ USING: combinators.short-circuit unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces make math.ranges unicode.normalize.private values -io.encodings.ascii unicode.syntax unicode.data compiler.units +io.encodings.ascii unicode.syntax unicode.data compiler.units fry alien.syntax sets accessors interval-maps memoize locals words ; IN: unicode.breaks @@ -111,14 +111,9 @@ PRIVATE> pieces) ( str quot -- ) - str [ - dup quot call cut-slice - swap , quot (>pieces) - ] unless-empty ; inline recursive - -: >pieces ( str quot -- graphemes ) - [ (>pieces) ] { } make ; inline +: >pieces ( str quot: ( str -- i ) -- graphemes ) + [ dup empty? not ] swap '[ dup @ cut-slice swap ] + [ ] produce nip ; inline PRIVATE> diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 0083e49672..f9d304e05c 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,7 +4,7 @@ USING: unicode.case tools.test namespaces ; \ >lower must-infer \ >title must-infer -[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test +[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 7e61831f36..5d103e2dd0 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: unicode.data sequences sequences.next namespaces make unicode.normalize math unicode.categories combinators -assocs strings splitting kernel accessors ; +assocs strings splitting kernel accessors unicode.breaks ; IN: unicode.case -: >lower ( string -- lower ) - i-dot? [ turk>lower ] when - final-sigma [ lower>> ] [ ch>lower ] map-case ; -: >upper ( string -- upper ) - i-dot? [ turk>upper ] when +: (>lower) ( string -- lower ) + [ lower>> ] [ ch>lower ] map-case ; + +: (>title) ( string -- title ) + [ title>> ] [ ch>title ] map-case ; + +: (>upper) ( string -- upper ) [ upper>> ] [ ch>upper ] map-case ; +: title-word ( string -- title ) + unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ; + +PRIVATE> + +: >lower ( string -- lower ) + i-dot? [ turk>lower ] when + final-sigma (>lower) ; + +: >upper ( string -- upper ) + i-dot? [ turk>upper ] when (>upper) ; + : >title ( string -- title ) - final-sigma - CHAR: \s swap - [ tuck word-boundary swapd - [ title>> ] [ lower>> ] if ] - [ tuck word-boundary swapd - [ ch>title ] [ ch>lower ] if ] - map-case nip ; + final-sigma >words [ title-word ] map concat ; : >case-fold ( string -- fold ) >upper >lower ; diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index be6af2d920..d3d0b8199d 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -1,6 +1,6 @@ USING: io io.files splitting grouping unicode.collation sequences kernel io.encodings.utf8 math.parser math.order -tools.test assocs io.streams.null words ; +tools.test assocs words ; IN: unicode.collation.tests : parse-test ( -- strings ) @@ -25,4 +25,4 @@ IN: unicode.collation.tests unit-test parse-test 2 -[ [ test-two ] assoc-each ] with-null-writer +[ test-two ] assoc-each diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index f13eb07594..58ce412a2e 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -155,7 +155,7 @@ DEFER: compose-iter ] if (compose) ] when* ; -: compose ( str -- comp ) +: combine ( str -- comp ) [ main-str set 0 ind set @@ -166,7 +166,7 @@ DEFER: compose-iter PRIVATE> : nfc ( string -- nfc ) - nfd compose ; + nfd combine ; : nfkc ( string -- nfkc ) - nfkd compose ; + nfkd combine ; From 6c89466706a743e54688330c19a64e18a1e01fae Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 7 Jan 2009 23:55:30 -0600 Subject: [PATCH 12/14] Add L-system.models.airhorse --- .../L-system/models/airhorse/airhorse.factor | 53 +++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 extra/L-system/models/airhorse/airhorse.factor diff --git a/extra/L-system/models/airhorse/airhorse.factor b/extra/L-system/models/airhorse/airhorse.factor new file mode 100644 index 0000000000..f65c7b824f --- /dev/null +++ b/extra/L-system/models/airhorse/airhorse.factor @@ -0,0 +1,53 @@ + +USING: accessors ui L-system ; + +IN: L-system.models.airhorse + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: airhorse ( -- ) + + L-parser-dialect >>commands + + [ 10 >>angle ] >>turtle-values + + "C" >>axiom + + { + { "C" "LBW" } + + { "B" "[[''aH]|[g]]" } + { "a" "Fs+;'a" } + { "g" "Ft+;'g" } + { "s" "[::cc!!!!&&[FFcccZ]^^^^FFcccZ]" } + { "t" "[c!!!!&[FF]^^FF]" } + + { "L" "O" } + { "O" "P" } + { "P" "Q" } + { "Q" "R" } + { "R" "U" } + { "U" "X" } + { "X" "Y" } + { "Y" "V" } + { "V" "[cc!!!&(90)[Zp]|[Zp]]" } + { "p" "h>(120)h>(120)h" } + { "h" "[+(40)!F'''p]" } + + { "H" "[cccci[>(50)dcFFF][<(50)ecFFF]]" } + { "d" "Z!&Z!&:'d" } + { "e" "Z!^Z!^:'e" } + { "i" "-:/i" } + + { "W" "[%[!!cb][<<>>!!cb]]" } + { "b" "Fl!+Fl+;'b" } + { "l" "[-cc{--z++z++z--|--z++z++z}]" } + } + >>rules ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: main ( -- ) [ L-system airhorse "L-system" open-window ] with-ui ; + +MAIN: main + \ No newline at end of file From 3b44c824ee8cd98955825bbc01ccb4bd4715d102 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 8 Jan 2009 17:00:48 +0100 Subject: [PATCH 13/14] FUEL: Better word extraction. --- misc/fuel/README | 3 ++- misc/fuel/fuel-mode.el | 3 ++- misc/fuel/fuel-refactor.el | 37 +++++++++++++++++++++++++------------ 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index f5d366a22e..4747adb4a0 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -74,7 +74,8 @@ beast. - C-cM-<, C-cC-d< : show callers of word at point - C-cM->, C-cC-d> : show callees of word at point - - C-cC-xw : extract region as a separate word + - C-cC-xs : extract innermost sexp (up to point) as a separate word + - C-cC-xr : extract region as a separate word *** In the listener: diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index c1abcf414b..467270651a 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -225,7 +225,8 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?w 'fuel-edit-word) (fuel-mode--key ?e ?x 'fuel-eval-definition) -(fuel-mode--key ?x ?w 'fuel-refactor-extract-word) +(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp) +(fuel-mode--key ?x ?r 'fuel-refactor-extract-region) (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 547da19552..a414f17795 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -20,23 +20,13 @@ ;;; Extract word: -(defun fuel-refactor-extract-word (begin end) - "Extracts current region as a separate word." - (interactive "r") +(defun fuel-refactor--extract (begin end) (let* ((word (read-string "New word name: ")) - (begin (save-excursion - (goto-char begin) - (when (zerop (skip-syntax-backward "w")) - (skip-syntax-forward "-")) - (point))) - (end (save-excursion - (goto-char end) - (skip-syntax-forward "w") - (point))) (code (buffer-substring begin end)) (code-str (fuel--region-to-string begin end)) (stack-effect (or (fuel-stack--infer-effect code-str) (read-string "Stack effect: ")))) + (unless (< begin end) (error "No proper region to extract")) (goto-char begin) (delete-region begin end) (insert word) @@ -52,6 +42,29 @@ (sit-for fuel-stack-highlight-period) (delete-overlay fuel-stack--overlay)))) +(defun fuel-refactor-extract-region (begin end) + "Extracts current region as a separate word." + (interactive "r") + (let ((begin (save-excursion + (goto-char begin) + (when (zerop (skip-syntax-backward "w")) + (skip-syntax-forward "-")) + (point))) + (end (save-excursion + (goto-char end) + (skip-syntax-forward "w") + (point)))) + (fuel-refactor--extract begin end))) + +(defun fuel-refactor-extract-sexp () + "Extracts current innermost sexp (up to point) as a separate +word." + (interactive) + (fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos)) + (if (looking-at-p ";") (point) + (fuel-syntax--end-of-symbol-pos)))) + + (provide 'fuel-refactor) ;;; fuel-refactor.el ends here From c5f55dc36d1d1467358178223f4446d07dfb9a16 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 8 Jan 2009 18:47:17 +0100 Subject: [PATCH 14/14] FUEL: New command: fuel-show-file-words. --- extra/fuel/fuel.factor | 3 ++ misc/fuel/README | 1 + misc/fuel/fuel-mode.el | 32 +------------- misc/fuel/fuel-syntax.el | 11 +++-- misc/fuel/fuel-xref.el | 93 +++++++++++++++++++++++++++++++++------- 5 files changed, 89 insertions(+), 51 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index becbf2161a..50f02f1a1a 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -201,6 +201,9 @@ SYMBOL: :uses : fuel-apropos-xref ( str -- ) words-matching fuel-format-xrefs fuel-eval-set-result ; inline +: fuel-vocab-xref ( vocab -- ) + words fuel-format-xrefs fuel-eval-set-result ; inline + ! Completion support : fuel-filter-prefix ( seq prefix -- seq ) diff --git a/misc/fuel/README b/misc/fuel/README index 4747adb4a0..f722b18598 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -70,6 +70,7 @@ beast. - C-cC-ds : short help word at point - C-cC-de : show stack effect of current sexp (with prefix, region) - C-cC-dp : find words containing given substring (M-x fuel-apropos) + - C-cC-dv : show words in current file (with prefix, ask for vocab) - C-cM-<, C-cC-d< : show callers of word at point - C-cM->, C-cC-d> : show callees of word at point diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 467270651a..f448e67d57 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -132,37 +132,6 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) -(defvar fuel-mode--word-history nil) - -(defun fuel-show-callers (&optional arg) - "Show a list of callers of word at point. -With prefix argument, ask for word." - (interactive "P") - (let ((word (if arg (fuel-completion--read-word "Find callers for: " - (fuel-syntax-symbol-at-point) - fuel-mode--word-history) - (fuel-syntax-symbol-at-point)))) - (when word - (message "Looking up %s's callers ..." word) - (fuel-xref--show-callers word)))) - -(defun fuel-show-callees (&optional arg) - "Show a list of callers of word at point. -With prefix argument, ask for word." - (interactive "P") - (let ((word (if arg (fuel-completion--read-word "Find callees for: " - (fuel-syntax-symbol-at-point) - fuel-mode--word-history) - (fuel-syntax-symbol-at-point)))) - (when word - (message "Looking up %s's callees ..." word) - (fuel-xref--show-callees word)))) - -(defun fuel-apropos (str) - "Show a list of words containing the given substring." - (interactive "MFind words containing: ") - (message "Looking up %s's references ..." str) - (fuel-xref--apropos str)) ;;; Minor mode definition: @@ -230,6 +199,7 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) +(fuel-mode--key ?d ?v 'fuel-show-file-words) (fuel-mode--key ?d ?a 'fuel-autodoc-mode) (fuel-mode--key ?d ?p 'fuel-apropos) (fuel-mode--key ?d ?d 'fuel-help) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 2c3de32d4f..e1981eff47 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -312,6 +312,12 @@ (defsubst fuel-syntax--usings () (funcall fuel-syntax--usings-function)) +(defun fuel-syntax--file-has-private () + (save-excursion + (goto-char (point-min)) + (and (re-search-forward "\\_<" nil t) + (re-search-forward "\\_\\_>" nil t)))) + (defun fuel-syntax--find-usings (&optional no-private) (save-excursion (let ((usings)) @@ -319,10 +325,7 @@ (while (re-search-backward fuel-syntax--using-lines-regex nil t) (dolist (u (split-string (match-string-no-properties 1) nil t)) (push u usings))) - (goto-char (point-min)) - (when (and (not no-private) - (re-search-forward "\\_<" nil t) - (re-search-forward "\\_\\_>" nil t)) + (when (and (not no-private) (fuel-syntax--file-has-private)) (goto-char (point-max)) (push (concat (fuel-syntax--find-in) ".private") usings)) usings))) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 470c2a8762..f754c626f7 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -13,6 +13,8 @@ ;;; Code: +(require 'fuel-edit) +(require 'fuel-completion) (require 'fuel-help) (require 'fuel-eval) (require 'fuel-syntax) @@ -82,7 +84,7 @@ cursor at the first ocurrence of the used word." ((= 1 count) (format "1 word %s %s:" cc word)) (t (format "%s words %s %s:" count cc word)))) -(defun fuel-xref--insert-ref (ref) +(defun fuel-xref--insert-ref (ref &optional no-vocab) (when (and (stringp (first ref)) (stringp (third ref)) (numberp (fourth ref))) @@ -94,29 +96,28 @@ cursor at the first ocurrence of the used word." (fourth ref)) 'file (third ref) 'line (fourth ref)) - (when (stringp (second ref)) + (when (and (not no-vocab) (stringp (second ref))) (insert (format " (in %s)" (second ref)))) (newline) t)) -(defun fuel-xref--fill-buffer (word cc refs) +(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app) (let ((inhibit-read-only t) (count 0)) (with-current-buffer (fuel-xref--buffer) - (erase-buffer) - (dolist (ref refs) - (when (fuel-xref--insert-ref ref) (setq count (1+ count)))) - (goto-char (point-min)) - (insert (fuel-xref--title word cc count) "\n\n") - (when (> count 0) - (setq fuel-xref--word (and cc word)) - (goto-char (point-max)) - (insert "\n" fuel-xref--help-string "\n")) - (goto-char (point-min)) - count))) + (let ((start (if app (goto-char (point-max)) + (erase-buffer) + (point-min)))) + (dolist (ref refs) + (when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count)))) + (newline) + (goto-char start) + (save-excursion + (insert (fuel-xref--title word cc count) "\n\n")) + count)))) -(defun fuel-xref--fill-and-display (word cc refs) - (let ((count (fuel-xref--fill-buffer word cc refs))) +(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab) + (let ((count (fuel-xref--fill-buffer word cc refs no-vocab))) (if (zerop count) (error (fuel-xref--title word cc 0)) (message "") @@ -137,6 +138,65 @@ cursor at the first ocurrence of the used word." (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) (fuel-xref--fill-and-display str "containing" res))) +(defun fuel-xref--show-vocab (vocab &optional app) + (let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab)) + (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (fuel-xref--fill-buffer vocab "in vocabulary" res t app))) + +(defun fuel-xref--show-vocab-words (vocab &optional private) + (fuel-xref--show-vocab vocab) + (when private + (fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab)) + t)) + (fuel-popup--display (fuel-xref--buffer)) + (goto-char (point-min))) + + +;;; User commands: + +(defvar fuel-xref--word-history nil) + +(defun fuel-show-callers (&optional arg) + "Show a list of callers of word at point. +With prefix argument, ask for word." + (interactive "P") + (let ((word (if arg (fuel-completion--read-word "Find callers for: " + (fuel-syntax-symbol-at-point) + fuel-xref--word-history) + (fuel-syntax-symbol-at-point)))) + (when word + (message "Looking up %s's callers ..." word) + (fuel-xref--show-callers word)))) + +(defun fuel-show-callees (&optional arg) + "Show a list of callers of word at point. +With prefix argument, ask for word." + (interactive "P") + (let ((word (if arg (fuel-completion--read-word "Find callees for: " + (fuel-syntax-symbol-at-point) + fuel-xref--word-history) + (fuel-syntax-symbol-at-point)))) + (when word + (message "Looking up %s's callees ..." word) + (fuel-xref--show-callees word)))) + +(defun fuel-apropos (str) + "Show a list of words containing the given substring." + (interactive "MFind words containing: ") + (message "Looking up %s's references ..." str) + (fuel-xref--apropos str)) + +(defun fuel-show-file-words (&optional arg) + "Show a list of words in current file. +With prefix argument, ask for the vocab." + (interactive "P") + (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) + (fuel-edit--read-vocabulary-name)))) + (when vocab + (fuel-xref--show-vocab-words vocab + (fuel-syntax--file-has-private))))) + + ;;; Xref mode: @@ -159,6 +219,7 @@ cursor at the first ocurrence of the used word." (kill-all-local-variables) (buffer-disable-undo) (use-local-map fuel-xref-mode-map) + (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Xref") (setq major-mode 'fuel-xref-mode) (font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab)))