From eb86d88dd4f2f9fd6ad9dd76d2a61084fc99d75f Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 9 Dec 2008 16:40:32 -0800
Subject: [PATCH 1/7] Fix typo in math.binpack-docs.
---
extra/math/binpack/binpack-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/math/binpack/binpack-docs.factor b/extra/math/binpack/binpack-docs.factor
index 36a29c7aa1..d995cab59d 100644
--- a/extra/math/binpack/binpack-docs.factor
+++ b/extra/math/binpack/binpack-docs.factor
@@ -15,5 +15,5 @@ HELP: binpack*
HELP: binpack!
{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } }
-{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ;
+{ $description "Packs a sequence of items into the specified number of bins, using the quotation to determine the weight." } ;
From e5e50767c3def48c2ce5f9c79f183055257d0261 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Sat, 13 Dec 2008 18:31:38 -0800
Subject: [PATCH 2/7] strftime: Add support for "%c" formats, and fix "%p".
---
extra/time/time.factor | 39 +++++++++++++++++++++++++--------------
1 file changed, 25 insertions(+), 14 deletions(-)
diff --git a/extra/time/time.factor b/extra/time/time.factor
index be19fb0919..52c01bdd88 100644
--- a/extra/time/time.factor
+++ b/extra/time/time.factor
@@ -1,18 +1,29 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors arrays calendar io kernel fry macros math
-math.functions math.parser peg.ebnf sequences strings vectors ;
+USING: accessors arrays calendar combinators io kernel fry
+macros math math.functions math.parser peg.ebnf sequences
+strings vectors ;
IN: time
+: zero-pad 2 CHAR: 0 pad-left ; inline
+
: >timestring ( timestamp -- string )
- [ hour>> ] keep [ minute>> ] keep second>> 3array
- [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline
+ [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
+ [ number>string zero-pad ] map ":" join ; inline
: >datestring ( timestamp -- string )
- [ month>> ] keep [ day>> ] keep year>> 3array
- [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline
+ [ month>> ] [ day>> ] [ year>> ] tri 3array
+ [ number>string zero-pad ] map "/" join ; inline
+
+: >datetimestring ( timestamp -- string )
+ { [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> number>string zero-pad ]
+ [ >timestring ]
+ [ year>> number>string ]
+ } cleave 3array [ 2array ] dip append " " join ; inline
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@@ -32,15 +43,15 @@ fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
fmt-B = "B" => [[ [ dup month>> month-name ] ]]
-fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]]
-fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]]
+fmt-c = "c" => [[ [ dup >datetimestring ] ]]
+fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
+fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
+fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
-fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]]
-fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]]
+fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
+fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
+fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
+fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
From e31b33bfbda95fc1e396be38d2d67a7c32bc4fef Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 15 Dec 2008 14:43:01 -0800
Subject: [PATCH 3/7] Merging printf and strftime into formatting vocab.
---
extra/{printf => formatting}/authors.txt | 0
extra/formatting/formatting-docs.factor | 123 ++++++++++++
.../formatting-tests.factor} | 73 ++-----
extra/formatting/formatting.factor | 186 ++++++++++++++++++
extra/{printf => formatting}/summary.txt | 0
extra/printf/printf-docs.factor | 80 --------
extra/printf/printf.factor | 112 -----------
extra/time/authors.txt | 1 -
extra/time/time-docs.factor | 43 ----
extra/time/time-tests.factor | 24 ---
extra/time/time.factor | 83 --------
11 files changed, 328 insertions(+), 397 deletions(-)
rename extra/{printf => formatting}/authors.txt (100%)
create mode 100644 extra/formatting/formatting-docs.factor
rename extra/{printf/printf-tests.factor => formatting/formatting-tests.factor} (84%)
create mode 100644 extra/formatting/formatting.factor
rename extra/{printf => formatting}/summary.txt (100%)
delete mode 100644 extra/printf/printf-docs.factor
delete mode 100644 extra/printf/printf.factor
delete mode 100644 extra/time/authors.txt
delete mode 100644 extra/time/time-docs.factor
delete mode 100644 extra/time/time-tests.factor
delete mode 100644 extra/time/time.factor
diff --git a/extra/printf/authors.txt b/extra/formatting/authors.txt
similarity index 100%
rename from extra/printf/authors.txt
rename to extra/formatting/authors.txt
diff --git a/extra/formatting/formatting-docs.factor b/extra/formatting/formatting-docs.factor
new file mode 100644
index 0000000000..c249f1d6f3
--- /dev/null
+++ b/extra/formatting/formatting-docs.factor
@@ -0,0 +1,123 @@
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: formatting
+
+HELP: printf
+{ $values { "format-string" string } }
+{ $description
+ "Writes the arguments (specified on the stack) formatted according to the format string.\n"
+ "\n"
+ "Several format specifications exist for handling arguments of different types, and "
+ "specifying attributes for the result string, including such things as maximum width, "
+ "padding, and decimals.\n"
+ { $table
+ { "%%" "Single %" "" }
+ { "%P.Ds" "String format" "string" }
+ { "%P.DS" "String format uppercase" "string" }
+ { "%c" "Character format" "char" }
+ { "%C" "Character format uppercase" "char" }
+ { "%+Pd" "Integer format" "fixnum" }
+ { "%+P.De" "Scientific notation" "fixnum, float" }
+ { "%+P.DE" "Scientific notation" "fixnum, float" }
+ { "%+P.Df" "Fixed format" "fixnum, float" }
+ { "%+Px" "Hexadecimal" "hex" }
+ { "%+PX" "Hexadecimal uppercase" "hex" }
+ }
+ "\n"
+ "A plus sign ('+') is used to optionally specify that the number should be "
+ "formatted with a '+' preceeding it if positive.\n"
+ "\n"
+ "Padding ('P') is used to optionally specify the minimum width of the result "
+ "string, the padding character, and the alignment. By default, the padding "
+ "character defaults to a space and the alignment defaults to right-aligned. "
+ "For example:\n"
+ { $list
+ "\"%5s\" formats a string padding with spaces up to 5 characters wide."
+ "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
+ "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
+ "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
+ }
+ "\n"
+ "Digits ('D') is used to optionally specify the maximum digits in the result "
+ "string. For example:\n"
+ { $list
+ "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
+ "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
+ }
+}
+{ $examples
+ { $example
+ "USING: printf ;"
+ "123 \"%05d\" printf"
+ "00123" }
+ { $example
+ "USING: printf ;"
+ "HEX: ff \"%04X\" printf"
+ "00FF" }
+ { $example
+ "USING: printf ;"
+ "1.23456789 \"%.3f\" printf"
+ "1.235" }
+ { $example
+ "USING: printf ;"
+ "1234567890 \"%.5e\" printf"
+ "1.23457e+09" }
+ { $example
+ "USING: printf ;"
+ "12 \"%'#4d\" printf"
+ "##12" }
+ { $example
+ "USING: printf ;"
+ "1234 \"%+d\" printf"
+ "+1234" }
+} ;
+
+HELP: sprintf
+{ $values { "format-string" string } { "result" string } }
+{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
+{ $see-also printf } ;
+
+HELP: strftime
+{ $values { "format-string" string } }
+{ $description
+ "Writes the timestamp (specified on the stack) formatted according to the format string.\n"
+ "\n"
+ "Different attributes of the timestamp can be retrieved using format specifications.\n"
+ { $table
+ { "%a" "Abbreviated weekday name." }
+ { "%A" "Full weekday name." }
+ { "%b" "Abbreviated month name." }
+ { "%B" "Full month name." }
+ { "%c" "Date and time representation." }
+ { "%d" "Day of the month as a decimal number [01,31]." }
+ { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
+ { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
+ { "%j" "Day of the year as a decimal number [001,366]." }
+ { "%m" "Month as a decimal number [01,12]." }
+ { "%M" "Minute as a decimal number [00,59]." }
+ { "%p" "Either AM or PM." }
+ { "%S" "Second as a decimal number [00,59]." }
+ { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
+ { "%w" "Weekday as a decimal number [0(Sunday),6]." }
+ { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
+ { "%x" "Date representation." }
+ { "%X" "Time representation." }
+ { "%y" "Year without century as a decimal number [00,99]." }
+ { "%Y" "Year with century as a decimal number." }
+ { "%Z" "Time zone name (no characters if no time zone exists)." }
+ { "%%" "A literal '%' character." }
+ }
+} ;
+
+ARTICLE: "formatting" "Formatted printing"
+"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n"
+{ $subsection printf }
+{ $subsection sprintf }
+{ $subsection strftime }
+;
+
+ABOUT: "formatting"
+
+
diff --git a/extra/printf/printf-tests.factor b/extra/formatting/formatting-tests.factor
similarity index 84%
rename from extra/printf/printf-tests.factor
rename to extra/formatting/formatting-tests.factor
index 2123784ea1..8616325a81 100644
--- a/extra/printf/printf-tests.factor
+++ b/extra/formatting/formatting-tests.factor
@@ -1,132 +1,97 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: kernel printf tools.test ;
+USING: calendar kernel formatting tools.test ;
+
+IN: formatting.tests
[ "%s" printf ] must-infer
-
[ "%s" sprintf ] must-infer
[ t ] [ "" "" sprintf = ] unit-test
-
[ t ] [ "asdf" "asdf" sprintf = ] unit-test
-
[ t ] [ "10" 10 "%d" sprintf = ] unit-test
-
[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
-
[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
-
[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
-
[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
-
[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
-
[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
-
[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
-
[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
-
[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
-
[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
-
[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
-
[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
-
[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
-
[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
-
[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
-
[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
-
[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
-
[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
-
[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
-
[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
-
[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
-
[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
-
[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
-
[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
-
[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
-
[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
-
[ t ] [ "2008-09-10"
2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
-
[ t ] [ "Hello, World!"
"Hello, World!" "%s" sprintf = ] unit-test
-
[ t ] [ "printf test"
"printf test" sprintf = ] unit-test
-
[ t ] [ "char a = 'a'"
CHAR: a "char %c = 'a'" sprintf = ] unit-test
-
[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
-
[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
-
[ t ] [ "0 message(s)"
0 "message" "%d %s(s)" sprintf = ] unit-test
-
[ t ] [ "0 message(s) with %"
0 "message" "%d %s(s) with %%" sprintf = ] unit-test
-
[ t ] [ "justif: \"left \""
"left" "justif: \"%-10s\"" sprintf = ] unit-test
-
[ t ] [ "justif: \" right\""
"right" "justif: \"%10s\"" sprintf = ] unit-test
-
[ t ] [ " 3: 0003 zero padded"
3 " 3: %04d zero padded" sprintf = ] unit-test
-
[ t ] [ " 3: 3 left justif"
3 " 3: %-4d left justif" sprintf = ] unit-test
-
[ t ] [ " 3: 3 right justif"
3 " 3: %4d right justif" sprintf = ] unit-test
-
[ t ] [ " -3: -003 zero padded"
-3 " -3: %04d zero padded" sprintf = ] unit-test
-
[ t ] [ " -3: -3 left justif"
-3 " -3: %-4d left justif" sprintf = ] unit-test
-
[ t ] [ " -3: -3 right justif"
-3 " -3: %4d right justif" sprintf = ] unit-test
-
[ t ] [ "There are 10 monkeys in the kitchen"
10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
-
[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
-
[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
-
[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
-
[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
-
[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
-
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
-
[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+[ "%H:%M:%S" strftime ] must-infer
+
+: testtime ( -- timestamp )
+ 2008 10 9 12 3 15 instant <timestamp> ;
+
+[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
+[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
+
+[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
+
+[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
+[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
+
+[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
+[ t ] [ "October" testtime "%B" strftime = ] unit-test
diff --git a/extra/formatting/formatting.factor b/extra/formatting/formatting.factor
new file mode 100644
index 0000000000..55ebfdf607
--- /dev/null
+++ b/extra/formatting/formatting.factor
@@ -0,0 +1,186 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays ascii calendar combinators fry kernel
+io io.encodings.ascii io.files io.streams.string
+macros math math.functions math.parser peg.ebnf quotations
+sequences splitting strings unicode.case vectors ;
+
+IN: formatting
+
+<PRIVATE
+
+: compose-all ( seq -- quot )
+ [ ] [ compose ] reduce ;
+
+: fix-sign ( string -- string )
+ dup CHAR: 0 swap index 0 =
+ [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
+ [ dup 1- rot dup [ nth ] dip swap
+ {
+ { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ [ drop swap drop ]
+ } case
+ ] [ drop ] if
+ ] when ;
+
+: >digits ( string -- digits )
+ [ 0 ] [ string>number ] if-empty ;
+
+: pad-digits ( string digits -- string' )
+ [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
+
+: max-digits ( n digits -- n' )
+ 10 swap ^ [ * round ] keep / ;
+
+: max-width ( string length -- string' )
+ short head ;
+
+: >exp ( x -- exp base )
+ [
+ abs 0 swap
+ [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
+ [ dup 10.0 >=
+ [ 10.0 / [ 1+ ] dip ]
+ [ 10.0 * [ 1- ] dip ] if
+ ] [ ] while
+ ] keep 0 < [ neg ] when ;
+
+: exp>string ( exp base digits -- string )
+ [ max-digits ] keep -rot
+ [
+ [ 0 < "-" "+" ? ]
+ [ abs number>string 2 CHAR: 0 pad-left ] bi
+ "e" -rot 3append
+ ]
+ [ number>string ] bi*
+ rot pad-digits prepend ;
+
+EBNF: parse-printf
+
+zero = "0" => [[ CHAR: 0 ]]
+char = "'" (.) => [[ second ]]
+
+pad-char = (zero|char)? => [[ CHAR: \s or ]]
+pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-width = ([0-9])* => [[ >digits ]]
+pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
+
+sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
+
+width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
+width = (width_)? => [[ [ ] or ]]
+
+digits_ = "." ([0-9])* => [[ second >digits ]]
+digits = (digits_)? => [[ 6 or ]]
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-c = "c" => [[ [ 1string ] ]]
+fmt-C = "C" => [[ [ 1string >upper ] ]]
+fmt-s = "s" => [[ [ ] ]]
+fmt-S = "S" => [[ [ >upper ] ]]
+fmt-d = "d" => [[ [ >fixnum number>string ] ]]
+fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
+fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
+fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
+fmt-x = "x" => [[ [ >hex ] ]]
+fmt-X = "X" => [[ [ >hex >upper ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+strings_ = fmt-c|fmt-C|fmt-s|fmt-S
+strings = pad width strings_ => [[ reverse compose-all ]]
+
+numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
+numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
+
+formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: printf ( format-string -- )
+ parse-printf [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
+
+: sprintf ( format-string -- result )
+ [ printf ] with-string-writer ; inline
+
+
+<PRIVATE
+
+: zero-pad 2 CHAR: 0 pad-left ; inline
+
+: >time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
+ [ number>string zero-pad ] map ":" join ; inline
+
+: >date ( timestamp -- string )
+ [ month>> ] [ day>> ] [ year>> ] tri 3array
+ [ number>string zero-pad ] map "/" join ; inline
+
+: >datetime ( timestamp -- string )
+ { [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> number>string zero-pad ]
+ [ >time ]
+ [ year>> number>string ]
+ } cleave 3array [ 2array ] dip append " " join ; inline
+
+: (week-of-year) ( timestamp day -- n )
+ [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+
+: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
+
+: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
+
+EBNF: parse-strftime
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
+fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
+fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
+fmt-B = "B" => [[ [ dup month>> month-name ] ]]
+fmt-c = "c" => [[ [ dup >datetime ] ]]
+fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
+fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
+fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
+fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
+fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
+fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
+fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
+fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
+fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
+fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
+fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
+fmt-x = "x" => [[ [ dup >date ] ]]
+fmt-X = "X" => [[ [ dup >time ] ]]
+fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
+fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
+fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
+ fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
+ fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
+
+formats = "%" (formats_) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: strftime ( format-string -- )
+ parse-strftime [ length ] keep [ ] join
+ '[ _ <vector> @ reverse concat nip ] ;
+
+
diff --git a/extra/printf/summary.txt b/extra/formatting/summary.txt
similarity index 100%
rename from extra/printf/summary.txt
rename to extra/formatting/summary.txt
diff --git a/extra/printf/printf-docs.factor b/extra/printf/printf-docs.factor
deleted file mode 100644
index 3ca9c07c36..0000000000
--- a/extra/printf/printf-docs.factor
+++ /dev/null
@@ -1,80 +0,0 @@
-
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
-
-IN: printf
-
-HELP: printf
-{ $values { "format-string" string } }
-{ $description "Writes the arguments (specified on the stack) formatted according to the format string." }
-{ $examples
- { $example
- "USING: printf ;"
- "123 \"%05d\" printf"
- "00123" }
- { $example
- "USING: printf ;"
- "HEX: ff \"%04X\" printf"
- "00FF" }
- { $example
- "USING: printf ;"
- "1.23456789 \"%.3f\" printf"
- "1.235" }
- { $example
- "USING: printf ;"
- "1234567890 \"%.5e\" printf"
- "1.23457e+09" }
- { $example
- "USING: printf ;"
- "12 \"%'#4d\" printf"
- "##12" }
- { $example
- "USING: printf ;"
- "1234 \"%+d\" printf"
- "+1234" }
-} ;
-
-HELP: sprintf
-{ $values { "format-string" string } { "result" string } }
-{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
-{ $see-also printf } ;
-
-ARTICLE: "printf" "Formatted printing"
-"The " { $vocab-link "printf" } " vocabulary is used for formatted printing.\n"
-{ $subsection printf }
-{ $subsection sprintf }
-"\n"
-"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
-{ $table
- { "%%" "Single %" "" }
- { "%P.Ds" "String format" "string" }
- { "%P.DS" "String format uppercase" "string" }
- { "%c" "Character format" "char" }
- { "%C" "Character format uppercase" "char" }
- { "%+Pd" "Integer format" "fixnum" }
- { "%+P.De" "Scientific notation" "fixnum, float" }
- { "%+P.DE" "Scientific notation" "fixnum, float" }
- { "%+P.Df" "Fixed format" "fixnum, float" }
- { "%+Px" "Hexadecimal" "hex" }
- { "%+PX" "Hexadecimal uppercase" "hex" }
-}
-"\n"
-"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n"
-"\n"
-"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n"
-{ $list
- "\"%5s\" formats a string padding with spaces up to 5 characters wide."
- "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
- "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
- "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
-}
-"\n"
-"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n"
-{ $list
- "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
- "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
- "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
-} ;
-
-ABOUT: "printf"
-
-
diff --git a/extra/printf/printf.factor b/extra/printf/printf.factor
deleted file mode 100644
index ac02efba69..0000000000
--- a/extra/printf/printf.factor
+++ /dev/null
@@ -1,112 +0,0 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: io io.encodings.ascii io.files io.streams.string combinators
-kernel sequences splitting strings math math.functions math.parser
-macros fry peg.ebnf ascii unicode.case arrays quotations vectors ;
-
-IN: printf
-
-<PRIVATE
-
-: compose-all ( seq -- quot )
- [ ] [ compose ] reduce ;
-
-: fix-sign ( string -- string )
- dup CHAR: 0 swap index 0 =
- [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
- [ dup 1- rot dup [ nth ] dip swap
- {
- { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
- { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
- [ drop swap drop ]
- } case
- ] [ drop ] if
- ] when ;
-
-: >digits ( string -- digits )
- [ 0 ] [ string>number ] if-empty ;
-
-: pad-digits ( string digits -- string' )
- [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
-
-: max-digits ( n digits -- n' )
- 10 swap ^ [ * round ] keep / ;
-
-: max-width ( string length -- string' )
- short head ;
-
-: >exp ( x -- exp base )
- [
- abs 0 swap
- [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
- [ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip ]
- [ 10.0 * [ 1- ] dip ] if
- ] [ ] while
- ] keep 0 < [ neg ] when ;
-
-: exp>string ( exp base digits -- string )
- [ max-digits ] keep -rot
- [
- [ 0 < "-" "+" ? ]
- [ abs number>string 2 CHAR: 0 pad-left ] bi
- "e" -rot 3append
- ]
- [ number>string ] bi*
- rot pad-digits prepend ;
-
-EBNF: parse-format-string
-
-zero = "0" => [[ CHAR: 0 ]]
-char = "'" (.) => [[ second ]]
-
-pad-char = (zero|char)? => [[ CHAR: \s or ]]
-pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
-pad-width = ([0-9])* => [[ >digits ]]
-pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
-
-sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
-
-width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
-width = (width_)? => [[ [ ] or ]]
-
-digits_ = "." ([0-9])* => [[ second >digits ]]
-digits = (digits_)? => [[ 6 or ]]
-
-fmt-% = "%" => [[ [ "%" ] ]]
-fmt-c = "c" => [[ [ 1string ] ]]
-fmt-C = "C" => [[ [ 1string >upper ] ]]
-fmt-s = "s" => [[ [ ] ]]
-fmt-S = "S" => [[ [ >upper ] ]]
-fmt-d = "d" => [[ [ >fixnum number>string ] ]]
-fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
-fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
-fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
-fmt-x = "x" => [[ [ >hex ] ]]
-fmt-X = "X" => [[ [ >hex >upper ] ]]
-unknown = (.)* => [[ "Unknown directive" throw ]]
-
-strings_ = fmt-c|fmt-C|fmt-s|fmt-S
-strings = pad width strings_ => [[ reverse compose-all ]]
-
-numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
-numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
-
-formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
-
-plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
-
-text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
-
-;EBNF
-
-PRIVATE>
-
-MACRO: printf ( format-string -- )
- parse-format-string [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
-
-: sprintf ( format-string -- result )
- [ printf ] with-string-writer ; inline
-
-
diff --git a/extra/time/authors.txt b/extra/time/authors.txt
deleted file mode 100644
index e091bb8164..0000000000
--- a/extra/time/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-John Benediktsson
diff --git a/extra/time/time-docs.factor b/extra/time/time-docs.factor
deleted file mode 100644
index 8fbc59e315..0000000000
--- a/extra/time/time-docs.factor
+++ /dev/null
@@ -1,43 +0,0 @@
-
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
-
-IN: time
-
-HELP: strftime
-{ $values { "format-string" string } }
-{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." }
-;
-
-ARTICLE: "strftime" "Formatted timestamps"
-"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n"
-{ $subsection strftime }
-"\n"
-"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
-{ $table
- { "%a" "Abbreviated weekday name." }
- { "%A" "Full weekday name." }
- { "%b" "Abbreviated month name." }
- { "%B" "Full month name." }
- { "%c" "Date and time representation." }
- { "%d" "Day of the month as a decimal number [01,31]." }
- { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
- { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
- { "%j" "Day of the year as a decimal number [001,366]." }
- { "%m" "Month as a decimal number [01,12]." }
- { "%M" "Minute as a decimal number [00,59]." }
- { "%p" "Either AM or PM." }
- { "%S" "Second as a decimal number [00,59]." }
- { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
- { "%w" "Weekday as a decimal number [0(Sunday),6]." }
- { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
- { "%x" "Date representation." }
- { "%X" "Time representation." }
- { "%y" "Year without century as a decimal number [00,99]." }
- { "%Y" "Year with century as a decimal number." }
- { "%Z" "Time zone name (no characters if no time zone exists)." }
- { "%%" "A literal '%' character." }
-} ;
-
-ABOUT: "strftime"
-
-
diff --git a/extra/time/time-tests.factor b/extra/time/time-tests.factor
deleted file mode 100644
index 0b0602bd62..0000000000
--- a/extra/time/time-tests.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel time tools.test calendar ;
-
-IN: time.tests
-
-[ "%H:%M:%S" strftime ] must-infer
-
-: testtime ( -- timestamp )
- 2008 10 9 12 3 15 instant <timestamp> ;
-
-[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
-[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
-
-[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
-[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
-
-[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
-[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
-
-[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
-[ t ] [ "October" testtime "%B" strftime = ] unit-test
-
diff --git a/extra/time/time.factor b/extra/time/time.factor
deleted file mode 100644
index 52c01bdd88..0000000000
--- a/extra/time/time.factor
+++ /dev/null
@@ -1,83 +0,0 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors arrays calendar combinators io kernel fry
-macros math math.functions math.parser peg.ebnf sequences
-strings vectors ;
-
-IN: time
-
-: zero-pad 2 CHAR: 0 pad-left ; inline
-
-: >timestring ( timestamp -- string )
- [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
- [ number>string zero-pad ] map ":" join ; inline
-
-: >datestring ( timestamp -- string )
- [ month>> ] [ day>> ] [ year>> ] tri 3array
- [ number>string zero-pad ] map "/" join ; inline
-
-: >datetimestring ( timestamp -- string )
- { [ day-of-week day-abbreviation3 ]
- [ month>> month-abbreviation ]
- [ day>> number>string zero-pad ]
- [ >timestring ]
- [ year>> number>string ]
- } cleave 3array [ 2array ] dip append " " join ; inline
-
-: (week-of-year) ( timestamp day -- n )
- [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
- [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
-
-: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
-
-: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
-
-
-<PRIVATE
-
-EBNF: parse-format-string
-
-fmt-% = "%" => [[ [ "%" ] ]]
-fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
-fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
-fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
-fmt-B = "B" => [[ [ dup month>> month-name ] ]]
-fmt-c = "c" => [[ [ dup >datetimestring ] ]]
-fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
-fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
-fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
-fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
-fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
-fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
-fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
-fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
-fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
-fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
-fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
-fmt-x = "x" => [[ [ dup >datestring ] ]]
-fmt-X = "X" => [[ [ dup >timestring ] ]]
-fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
-fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
-fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
-unknown = (.)* => [[ "Unknown directive" throw ]]
-
-formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
- fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
- fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
-
-formats = "%" (formats_) => [[ second '[ _ dip ] ]]
-
-plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
-
-text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
-
-;EBNF
-
-PRIVATE>
-
-MACRO: strftime ( format-string -- )
- parse-format-string [ length ] keep [ ] join
- '[ _ <vector> @ reverse concat nip ] ;
-
-
From 6a144cc54687f10273d451405d2677705b39807e Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Mon, 15 Dec 2008 23:44:13 +0100
Subject: [PATCH 4/7] FUEL: Initial word completion (M-TAB) plus lotsa fixes.
---
extra/fuel/fuel.factor | 39 ++++++--
misc/fuel/README | 1 +
misc/fuel/factor-mode.el | 3 +-
misc/fuel/fuel-base.el | 7 ++
misc/fuel/fuel-completion.el | 173 +++++++++++++++++++++++++++++++++++
misc/fuel/fuel-connection.el | 57 +++++++-----
misc/fuel/fuel-debug.el | 3 +-
misc/fuel/fuel-eval.el | 4 +-
misc/fuel/fuel-help.el | 6 +-
misc/fuel/fuel-listener.el | 58 ++++++------
misc/fuel/fuel-log.el | 17 ++--
misc/fuel/fuel-mode.el | 44 +++++----
misc/fuel/fuel-syntax.el | 60 ++++++------
13 files changed, 348 insertions(+), 124 deletions(-)
create mode 100644 misc/fuel/fuel-completion.el
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 2de80de4a4..5a39fe9f2b 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -1,12 +1,13 @@
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes classes.tuple compiler.units
-combinators continuations debugger definitions eval help io
-io.files io.pathnames io.streams.string kernel lexer listener
-listener.private make math namespaces parser prettyprint
-prettyprint.config quotations sequences strings source-files
-tools.vocabs vectors vocabs vocabs.loader ;
+USING: accessors arrays assocs classes classes.tuple
+combinators compiler.units continuations debugger definitions
+eval help io io.files io.pathnames io.streams.string kernel
+lexer listener listener.private make math memoize namespaces
+parser prettyprint prettyprint.config quotations sequences sets
+sorting source-files strings tools.vocabs vectors vocabs
+vocabs.loader ;
IN: fuel
@@ -88,6 +89,14 @@ SYMBOL: :restarts
M: condition fuel-pprint
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
+M: lexer-error fuel-pprint
+ {
+ [ line>> ]
+ [ column>> ]
+ [ line-text>> ]
+ [ fuel-restarts ]
+ } cleave 4array lexer-error prefix fuel-pprint ;
+
M: source-file-error fuel-pprint
[ file>> ] [ error>> ] bi 2array source-file-error prefix
fuel-pprint ;
@@ -159,8 +168,24 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ;
+: (fuel-get-vocabs) ( -- seq )
+ all-vocabs-seq [ vocab-name ] map ; inline
+
: fuel-get-vocabs ( -- )
- all-vocabs-seq [ vocab-name ] map fuel-eval-set-result ; inline
+ (fuel-get-vocabs) fuel-eval-set-result ;
+
+MEMO: (fuel-vocab-words) ( name -- seq )
+ >vocab-link words [ name>> ] map ;
+
+: fuel-vocabs-words ( names/f -- seq )
+ [ (fuel-get-vocabs) ] unless* prune
+ [ (fuel-vocab-words) ] map concat natural-sort ;
+
+: (fuel-get-words) ( prefix names/f -- seq )
+ fuel-vocabs-words swap [ drop-prefix nip length 0 = ] curry filter ;
+
+: fuel-get-words ( prefix names -- )
+ (fuel-get-words) fuel-eval-set-result ; inline
: fuel-run-file ( path -- ) run-file ; inline
diff --git a/misc/fuel/README b/misc/fuel/README
index dc6db388e6..3754e816a9 100644
--- a/misc/fuel/README
+++ b/misc/fuel/README
@@ -56,6 +56,7 @@ the same as C-cz)).
- C-co : cycle between code, tests and docs factor files
- M-. : edit word at point in Emacs (also in listener)
+ - M-TAB : complete word at point
- C-cC-ev : edit vocabulary
- C-cr, C-cC-er : eval region
diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el
index 2f73a62738..8cf578f090 100644
--- a/misc/fuel/factor-mode.el
+++ b/misc/fuel/factor-mode.el
@@ -84,8 +84,7 @@ code in the buffer."
(set (make-local-variable 'beginning-of-defun-function)
'fuel-syntax--beginning-of-defun)
(set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun)
- (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
- (fuel-syntax--enable-usings))
+ (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil))
;;; Indentation:
diff --git a/misc/fuel/fuel-base.el b/misc/fuel/fuel-base.el
index 9ea1790380..f60c5f241d 100644
--- a/misc/fuel/fuel-base.el
+++ b/misc/fuel/fuel-base.el
@@ -61,5 +61,12 @@
(defsubst empty-string-p (str) (equal str ""))
+(defun fuel--respecting-message (format &rest format-args)
+ "Display TEXT as a message, without hiding any minibuffer contents."
+ (let ((text (format " [%s]" (apply #'format format format-args))))
+ (if (minibuffer-window-active-p (minibuffer-window))
+ (minibuffer-message text)
+ (message "%s" text))))
+
(provide 'fuel-base)
;;; fuel-base.el ends here
diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el
new file mode 100644
index 0000000000..bffa2aa0fc
--- /dev/null
+++ b/misc/fuel/fuel-completion.el
@@ -0,0 +1,173 @@
+;;; fuel-completion.el -- completion utilities
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 14, 2008 21:17
+
+;;; Comentary:
+
+;; Code completion utilities.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+(require 'fuel-eval)
+(require 'fuel-log)
+
+
+;;; Vocabs dictionary:
+
+(defvar fuel-completion--vocabs nil)
+
+(defun fuel-completion--vocabs (&optional reload)
+ (when (or reload (not fuel-completion--vocabs))
+ (fuel--respecting-message "Retrieving vocabs list")
+ (let ((fuel-log--inhibit-p t))
+ (setq fuel-completion--vocabs
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
+ fuel-completion--vocabs)
+
+(defsubst fuel-completion--words (prefix vocabs)
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,prefix V{ ,@vocabs } fuel-get-words) t ,vocabs))))
+
+
+;;; Completions window handling, heavily inspired in slime's:
+
+(defvar fuel-completion--comp-buffer "*Completions*")
+
+(make-variable-buffer-local
+ (defvar fuel-completion--window-cfg nil
+ "Window configuration before we show the *Completions* buffer.
+This is buffer local in the buffer where the completion is
+performed."))
+
+(make-variable-buffer-local
+ (defvar fuel-completion--completions-window nil
+ "The window displaying *Completions* after saving window configuration.
+If this window is no longer active or displaying the completions
+buffer then we can ignore `fuel-completion--window-cfg'."))
+
+(defun fuel-completion--maybe-save-window-configuration ()
+ "Maybe save the current window configuration.
+Return true if the configuration was saved."
+ (unless (or fuel-completion--window-cfg
+ (get-buffer-window fuel-completion--comp-buffer))
+ (setq fuel-completion--window-cfg
+ (current-window-configuration))
+ t))
+
+(defun fuel-completion--delay-restoration ()
+ (add-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration
+ nil t))
+
+(defun fuel-completion--forget-window-configuration ()
+ (setq fuel-completion--window-cfg nil)
+ (setq fuel-completion--completions-window nil))
+
+(defun fuel-completion--restore-window-configuration ()
+ "Restore the window config if available."
+ (remove-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration)
+ (when (and fuel-completion--window-cfg
+ (fuel-completion--window-active-p))
+ (save-excursion
+ (set-window-configuration fuel-completion--window-cfg))
+ (setq fuel-completion--window-cfg nil)
+ (when (buffer-live-p fuel-completion--comp-buffer)
+ (kill-buffer fuel-completion--comp-buffer))))
+
+(defun fuel-completion--maybe-restore-window-configuration ()
+ "Restore the window configuration, if the following command
+terminates a current completion."
+ (remove-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration)
+ (condition-case err
+ (cond ((find last-command-char "()\"'`,# \r\n:")
+ (fuel-completion--restore-window-configuration))
+ ((not (fuel-completion--window-active-p))
+ (fuel-completion--forget-window-configuration))
+ (t (fuel-completion--delay-restoration)))
+ (error
+ ;; Because this is called on the pre-command-hook, we mustn't let
+ ;; errors propagate.
+ (message "Error in fuel-completion--restore-window-configuration: %S" err))))
+
+(defun fuel-completion--window-active-p ()
+ "Is the completion window currently active?"
+ (and (window-live-p fuel-completion--completions-window)
+ (equal (buffer-name (window-buffer fuel-completion--completions-window))
+ fuel-completion--comp-buffer)))
+
+(defun fuel-completion--display-comp-list (completions base)
+ (let ((savedp (fuel-completion--maybe-save-window-configuration)))
+ (with-output-to-temp-buffer fuel-completion--comp-buffer
+ (display-completion-list completions)
+ (let ((offset (- (point) 1 (length base))))
+ (with-current-buffer standard-output
+ (setq completion-base-size offset)
+ (set-syntax-table fuel-syntax--syntax-table))))
+ (when savedp
+ (setq fuel-completion--completions-window
+ (get-buffer-window fuel-completion--comp-buffer)))))
+
+(defun fuel-completion--display-or-scroll (completions base)
+ (cond ((and (eq last-command this-command) (fuel-completion--window-active-p))
+ (fuel-completion--scroll-completions))
+ (t (fuel-completion--display-comp-list completions base)))
+ (fuel-completion--delay-restoration))
+
+(defun fuel-completion--scroll-completions ()
+ (let ((window fuel-completion--completions-window))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ (set-window-start window (point-min))
+ (save-selected-window
+ (select-window window)
+ (scroll-up))))))
+
+
+;;; Completion functionality:
+
+(defsubst fuel-completion--word-list (prefix)
+ (let ((fuel-log--inhibit-p t))
+ (fuel-completion--words
+ prefix `("syntax" ,(fuel-syntax--current-vocab) ,@(fuel-syntax--usings)))))
+
+(defun fuel-completion--complete (prefix)
+ (let* ((words (fuel-completion--word-list prefix))
+ (completions (all-completions prefix words))
+ (partial (try-completion prefix words))
+ (partial (if (eq partial t) prefix partial)))
+ (cons completions partial)))
+
+(defun fuel-completion--complete-symbol ()
+ "Complete the symbol at point.
+Perform completion similar to Emacs' complete-symbol."
+ (interactive)
+ (let* ((end (point))
+ (beg (fuel-syntax--symbol-start))
+ (prefix (buffer-substring-no-properties beg end))
+ (result (fuel-completion--complete prefix))
+ (completions (car result))
+ (partial (cdr result)))
+ (cond ((null completions)
+ (fuel--respecting-message "Can't find completion for %S" prefix)
+ (fuel-completion--restore-window-configuration))
+ (t (insert-and-inherit (substring partial (length prefix)))
+ (cond ((= (length completions) 1)
+ (fuel--respecting-message "Sole completion")
+ (fuel-completion--restore-window-configuration))
+ (t (fuel--respecting-message "Complete but not unique")
+ (fuel-completion--display-or-scroll completions
+ partial)))))))
+
+
+(provide 'fuel-completion)
+;;; fuel-completion.el ends here
diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el
index 168501171e..af793057ff 100644
--- a/misc/fuel/fuel-connection.el
+++ b/misc/fuel/fuel-connection.el
@@ -74,10 +74,11 @@
(defsubst fuel-con--make-connection (buffer)
(list :fuel-connection
- (list :requests)
- (list :current)
+ (cons :requests (list))
+ (cons :current nil)
(cons :completed (make-hash-table :weakness 'value))
- (cons :buffer buffer)))
+ (cons :buffer buffer)
+ (cons :timer nil)))
(defsubst fuel-con--connection-p (c)
(and (listp c) (eq (car c) :fuel-connection)))
@@ -110,6 +111,15 @@
(fuel-con--connection-pop-request c)
(cdr current))))
+(defun fuel-con--connection-start-timer (c)
+ (let ((cell (assoc :timer c)))
+ (when (cdr cell) (cancel-timer (cdr cell)))
+ (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
+
+(defun fuel-con--connection-cancel-timer (c)
+ (let ((cell (assoc :timer c)))
+ (when (cdr cell) (cancel-timer (cdr cell)))))
+
;;; Connection setup:
@@ -117,7 +127,9 @@
(set-buffer buffer)
(let ((conn (fuel-con--make-connection buffer)))
(fuel-con--setup-comint)
- (setq fuel-con--connection conn)))
+ (prog1
+ (setq fuel-con--connection conn)
+ (fuel-con--connection-start-timer conn))))
(defun fuel-con--setup-comint ()
(add-hook 'comint-redirect-filter-functions
@@ -133,13 +145,13 @@
(let* ((buffer (fuel-con--connection-buffer con))
(req (fuel-con--connection-pop-request con))
(str (and req (fuel-con--request-string req))))
- (when (and buffer req str)
- (set-buffer buffer)
- (when fuel-log--verbose-p
- (with-current-buffer (fuel-log--buffer)
- (let ((inhibit-read-only t))
- (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str))))
- (comint-redirect-send-command str (fuel-log--buffer) nil t)))))
+ (if (not (buffer-live-p buffer))
+ (fuel-con--connection-cancel-timer con)
+ (when (and buffer req str)
+ (set-buffer buffer)
+ (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
+ (comint-redirect-send-command (format "%s" str)
+ (fuel-log--buffer) nil t))))))
(defun fuel-con--process-completed-request (req)
(let ((str (fuel-con--request-output req))
@@ -155,7 +167,7 @@
(funcall cont str)
(fuel-log--info "<%s>: processed\n\t%s" id str))
(error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
- id rstr cerr))))))
+ id rstr cerr))))))
(defun fuel-con--comint-redirect-filter (str)
(if (not fuel-con--connection)
@@ -164,7 +176,7 @@
(if (not req) (fuel-log--error "No current request (%s)" str)
(fuel-con--request-output req str)
(fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
- ".")
+ (fuel--shorten-str str 70))
(defun fuel-con--comint-redirect-hook ()
(if (not fuel-con--connection)
@@ -193,15 +205,18 @@
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
(save-current-buffer
(let* ((con (fuel-con--get-connection buffer/proc))
- (req (fuel-con--send-string buffer/proc str cont sbuf))
- (id (and req (fuel-con--request-id req)))
- (time (or timeout fuel-connection-timeout))
- (step 2))
+ (req (fuel-con--send-string buffer/proc str cont sbuf))
+ (id (and req (fuel-con--request-id req)))
+ (time (or timeout fuel-connection-timeout))
+ (step 100)
+ (waitsecs (/ step 1000.0)))
(when id
- (while (and (> time 0)
- (not (fuel-con--connection-completed-p con id)))
- (sleep-for 0 step)
- (setq time (- time step)))
+ (condition-case nil
+ (while (and (> time 0)
+ (not (fuel-con--connection-completed-p con id)))
+ (accept-process-output nil waitsecs)
+ (setq time (- time step)))
+ (error (setq time 1)))
(or (> time 0)
(fuel-con--request-deactivate req)
nil)))))
diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el
index d34b31903e..46c1f74f0f 100644
--- a/misc/fuel/fuel-debug.el
+++ b/misc/fuel/fuel-debug.el
@@ -119,6 +119,7 @@
(setq fuel-debug--last-ret ret)
(setq fuel-debug--file file)
(goto-char (point-max))
+ (font-lock-fontify-buffer)
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
(not err))))
@@ -130,7 +131,7 @@
(trail (and last (substring-no-properties last (/ llen 2))))
(err (fuel-eval--retort-error ret))
(p (point)))
- (save-excursion (insert current))
+ (when current (save-excursion (insert current)))
(when (and (> clen llen) (> llen 0) (search-forward trail nil t))
(delete-region p (point)))
(goto-char (point-max))
diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el
index 07c2ca3445..f14e4a922c 100644
--- a/misc/fuel/fuel-eval.el
+++ b/misc/fuel/fuel-eval.el
@@ -17,6 +17,8 @@
(require 'fuel-syntax)
(require 'fuel-connection)
+(eval-when-compile (require 'cl))
+
;;; Simple sexp-based representation of factor code
@@ -39,7 +41,7 @@
(:rs 'fuel-eval-restartable)
(:nrs 'fuel-eval-non-restartable)
(:in (fuel-syntax--current-vocab))
- (:usings `(:array ,@(fuel-syntax--usings-update)))
+ (:usings `(:array ,@(fuel-syntax--usings)))
(:get 'fuel-eval-set-result)
(t `(:factor ,(symbol-name sexp))))))
((symbolp sexp) (symbol-name sexp))))
diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el
index d4bf757cd7..8170b31a1b 100644
--- a/misc/fuel/fuel-help.el
+++ b/misc/fuel/fuel-help.el
@@ -73,7 +73,7 @@
(defun fuel-help--word-synopsis (&optional word)
(let ((word (or word (fuel-syntax-symbol-at-point)))
- (fuel-eval--log t))
+ (fuel-log--inhibit-p t))
(when word
(let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
(ret (fuel-eval--send/wait cmd 20)))
@@ -157,7 +157,7 @@ displayed in the minibuffer."
(defun fuel-help--show-help-cont (def ret)
(let ((out (fuel-eval--retort-output ret)))
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
- (message "No help for '%s'" def)
+ (message "No help for '%s'" ret)
(fuel-help--insert-contents def out))))
(defun fuel-help--insert-contents (def str &optional nopush)
@@ -225,6 +225,8 @@ buffer."
(define-key map "q" 'bury-buffer)
(define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next)
+ (define-key map "l" 'fuel-help-previous)
+ (define-key map "n" 'fuel-help-next)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
map))
diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el
index c72f66b21c..7c71cbf03c 100644
--- a/misc/fuel/fuel-listener.el
+++ b/misc/fuel/fuel-listener.el
@@ -49,9 +49,16 @@ buffer."
;;; Fuel listener buffer/process:
-(defvar fuel-listener-buffer nil
+(defvar fuel-listener--buffer nil
"The buffer in which the Factor listener is running.")
+(defun fuel-listener--buffer ()
+ (if (buffer-live-p fuel-listener--buffer)
+ fuel-listener--buffer
+ (with-current-buffer (get-buffer-create "*fuel listener*")
+ (fuel-listener-mode)
+ (setq fuel-listener--buffer (current-buffer)))))
+
(defun fuel-listener--start-process ()
(let ((factor (expand-file-name fuel-listener-factor-binary))
(image (expand-file-name fuel-listener-factor-image)))
@@ -59,19 +66,18 @@ buffer."
(error "Could not run factor: %s is not executable" factor))
(unless (file-readable-p image)
(error "Could not run factor: image file %s not readable" image))
- (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
- (with-current-buffer fuel-listener-buffer
- (fuel-listener-mode)
- (message "Starting FUEL listener ...")
- (comint-exec fuel-listener-buffer "factor"
- factor nil `("-run=fuel" ,(format "-i=%s" image)))
- (fuel-listener--wait-for-prompt 20)
- (fuel-eval--send/wait "USE: fuel")
- (message "FUEL listener up and running!"))))
+ (message "Starting FUEL listener ...")
+ (comint-exec (fuel-listener--buffer) "factor"
+ factor nil `("-run=fuel" ,(format "-i=%s" image)))
+ (pop-to-buffer (fuel-listener--buffer))
+ (goto-char (point-max))
+ (comint-send-string nil "USE: fuel \"\\nFUEL loaded\\n\" write\n")
+ (fuel-listener--wait-for-prompt 30)
+ (message "FUEL listener up and running!")))
(defun fuel-listener--process (&optional start)
- (or (and (buffer-live-p fuel-listener-buffer)
- (get-buffer-process fuel-listener-buffer))
+ (or (and (buffer-live-p (fuel-listener--buffer))
+ (get-buffer-process (fuel-listener--buffer)))
(if (not start)
(error "No running factor listener (try M-x run-factor)")
(fuel-listener--start-process)
@@ -83,18 +89,17 @@ buffer."
;;; Prompt chasing
(defun fuel-listener--wait-for-prompt (&optional timeout)
- (let ((proc (get-buffer-process fuel-listener-buffer)))
- (with-current-buffer fuel-listener-buffer
- (goto-char (or comint-last-input-end (point-min)))
- (let ((seen (re-search-forward comint-prompt-regexp nil t)))
- (while (and (not seen)
- (accept-process-output proc (or timeout 10) nil t))
- (sleep-for 0 1)
- (goto-char comint-last-input-end)
- (setq seen (re-search-forward comint-prompt-regexp nil t)))
- (pop-to-buffer fuel-listener-buffer)
- (goto-char (point-max))
- (unless seen (error "No prompt found!"))))))
+ (let ((proc (get-buffer-process (fuel-listener--buffer)))
+ (seen))
+ (with-current-buffer (fuel-listener--buffer)
+ (goto-char (or comint-last-input-end (point-max)))
+ (while (and (not seen)
+ (accept-process-output proc (or timeout 10) nil t))
+ (sleep-for 0 1)
+ (goto-char comint-last-input-end)
+ (setq seen (re-search-forward comint-prompt-regexp nil t)))
+ (goto-char (point-max))
+ (unless seen (error "No prompt found!")))))
;;; Interface: starting fuel listener
@@ -114,13 +119,12 @@ buffer."
;;; Fuel listener mode:
-(defconst fuel-listener--prompt-regex "( [^)]* ) ")
+(defconst fuel-listener--prompt-regex ".* ) ")
(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
"Major mode for interacting with an inferior Factor listener process.
\\{fuel-listener-mode-map}"
- (set (make-local-variable 'comint-prompt-regexp)
- fuel-listener--prompt-regex)
+ (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex)
(set (make-local-variable 'comint-prompt-read-only) t)
(setq fuel-listener--compilation-begin nil))
diff --git a/misc/fuel/fuel-log.el b/misc/fuel/fuel-log.el
index ba048a6157..fee762d09a 100644
--- a/misc/fuel/fuel-log.el
+++ b/misc/fuel/fuel-log.el
@@ -31,6 +31,9 @@
(defvar fuel-log--verbose-p t
"Log level for Factor messages")
+(defvar fuel-log--inhibit-p nil
+ "Set this to t to inhibit all log messages")
+
(define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages"
"Simple mode to log interactions with the factor listener"
(kill-all-local-variables)
@@ -52,11 +55,12 @@
(current-buffer))))
(defun fuel-log--msg (type &rest args)
- (with-current-buffer (fuel-log--buffer)
- (let ((inhibit-read-only t))
- (insert
- (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args))
- fuel-log--max-message-size)))))
+ (unless fuel-log--inhibit-p
+ (with-current-buffer (fuel-log--buffer)
+ (let ((inhibit-read-only t))
+ (insert
+ (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args))
+ fuel-log--max-message-size))))))
(defsubst fuel-log--warn (&rest args)
(apply 'fuel-log--msg 'WARNING args))
@@ -65,7 +69,8 @@
(apply 'fuel-log--msg 'ERROR args))
(defsubst fuel-log--info (&rest args)
- (if fuel-log--verbose-p (apply 'fuel-log--msg 'INFO args) ""))
+ (when fuel-log--verbose-p
+ (apply 'fuel-log--msg 'INFO args) ""))
(provide 'fuel-log)
diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el
index 2dc15ce272..0f8e600165 100644
--- a/misc/fuel/fuel-mode.el
+++ b/misc/fuel/fuel-mode.el
@@ -21,6 +21,7 @@
(require 'fuel-debug)
(require 'fuel-help)
(require 'fuel-eval)
+(require 'fuel-completion)
(require 'fuel-listener)
@@ -67,13 +68,12 @@ buffer in case of errors."
(interactive "r\nP")
(let* ((lines (split-string (buffer-substring-no-properties begin end)
"[\f\n\r\v]+" t))
- (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines)))))
+ (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))
+ (cv (fuel-syntax--current-vocab)))
(fuel-debug--display-retort
(fuel-eval--send/wait cmd 10000)
(format "%s%s"
- (if fuel-syntax--current-vocab
- (format "IN: %s " fuel-syntax--current-vocab)
- "")
+ (if cv (format "IN: %s " cv) "")
(fuel--shorten-region begin end 70))
arg
(buffer-file-name))))
@@ -125,23 +125,24 @@ With prefix, asks for the word to edit."
(let ((cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
(condition-case nil
(fuel--try-edit (fuel-eval--send/wait cmd))
- (error (fuel-edit-vocabulary word))))))
+ (error (fuel-edit-vocabulary nil word))))))
(defvar fuel--vocabs-prompt-history nil)
-(defun fuel--read-vocabulary-name ()
- (let* ((cmd '(:fuel* (fuel-get-vocabs) "fuel" t))
- (vocabs (fuel-eval--retort-result (fuel-eval--send/wait cmd)))
+(defun fuel--read-vocabulary-name (refresh)
+ (let* ((vocabs (fuel-completion--vocabs refresh))
(prompt "Vocabulary name: "))
(if vocabs
(completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
(read-string prompt nil fuel--vocabs-prompt-history))))
-(defun fuel-edit-vocabulary (vocab)
+(defun fuel-edit-vocabulary (&optional refresh vocab)
"Visits vocabulary file in Emacs.
-When called interactively, asks for vocabulary with completion."
- (interactive (list (fuel--read-vocabulary-name)))
- (let* ((cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
+When called interactively, asks for vocabulary with completion.
+With prefix argument, refreshes cached vocabulary list."
+ (interactive "P")
+ (let* ((vocab (or vocab (fuel--read-vocabulary-name refresh)))
+ (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
(fuel--try-edit (fuel-eval--send/wait cmd))))
@@ -183,22 +184,19 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
(fuel-mode--key-1 ?z 'run-factor)
-
(fuel-mode--key-1 ?k 'fuel-run-file)
-(fuel-mode--key ?e ?k 'fuel-run-file)
+(fuel-mode--key-1 ?r 'fuel-eval-region)
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
-(fuel-mode--key ?e ?x 'fuel-eval-definition)
-
-(fuel-mode--key-1 ?r 'fuel-eval-region)
-(fuel-mode--key ?e ?r 'fuel-eval-region)
-
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
-(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
-
-(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
-
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
+
+(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?r 'fuel-eval-region)
+(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
+(fuel-mode--key ?e ?w 'fuel-edit-word-at-point)
+(fuel-mode--key ?e ?x 'fuel-eval-definition)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?d 'fuel-help)
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index ff8126c507..a492a7b647 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -22,11 +22,17 @@
(while (eq (char-before) ?:) (backward-char))
(skip-syntax-backward "w_"))
+(defsubst fuel-syntax--symbol-start ()
+ (save-excursion (fuel-syntax--beginning-of-symbol) (point)))
+
(defun fuel-syntax--end-of-symbol ()
"Move point to the end of the current symbol."
(skip-syntax-forward "w_")
(while (looking-at ":") (forward-char)))
+(defsubst fuel-syntax--symbol-end ()
+ (save-excursion (fuel-syntax--end-of-symbol) (point)))
+
(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol)
@@ -34,6 +40,7 @@
(let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
(and (> (length s) 0) s)))
+
;;; Regexps galore:
@@ -43,7 +50,7 @@
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"IN:" "INSTANCE:" "INTERSECTION:"
- "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+ "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
@@ -91,7 +98,7 @@
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
(defconst fuel-syntax--definition-starters-regex
- (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+ (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "METHOD" ":" "")))
(defconst fuel-syntax--definition-start-regex
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
@@ -234,18 +241,13 @@
;;; USING/IN:
-(make-variable-buffer-local
- (defvar fuel-syntax--current-vocab nil))
-
-(make-variable-buffer-local
- (defvar fuel-syntax--usings nil))
-
(defun fuel-syntax--current-vocab ()
- (let ((ip
- (save-excursion
- (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
- (setq fuel-syntax--current-vocab (match-string-no-properties 1))
- (point)))))
+ (let* ((vocab)
+ (ip
+ (save-excursion
+ (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
+ (setq vocab (match-string-no-properties 1))
+ (point)))))
(when ip
(let ((pp (save-excursion
(when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
@@ -253,29 +255,19 @@
(when (and pp (> pp ip))
(let ((sub (match-string-no-properties 1)))
(unless (save-excursion (search-backward (format "%s>" sub) pp t))
- (setq fuel-syntax--current-vocab
- (format "%s.%s" fuel-syntax--current-vocab (downcase sub)))))))))
- fuel-syntax--current-vocab)
+ (setq vocab (format "%s.%s" vocab (downcase sub))))))))
+ vocab))
-(defun fuel-syntax--usings-update ()
+(defun fuel-syntax--usings ()
(save-excursion
- (let ((in (fuel-syntax--current-vocab)))
- (setq fuel-syntax--usings (and in (list in))))
- (while (re-search-backward fuel-syntax--using-lines-regex nil t)
- (dolist (u (split-string (match-string-no-properties 1) nil t))
- (push u fuel-syntax--usings)))
- fuel-syntax--usings))
-
-(defsubst fuel-syntax--usings-update-hook ()
- (fuel-syntax--usings-update)
- nil)
-
-(defun fuel-syntax--enable-usings ()
- (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t)
- (fuel-syntax--usings-update))
-
-(defsubst fuel-syntax--usings ()
- (or fuel-syntax--usings (fuel-syntax--usings-update)))
+ (let ((usings)
+ (in (fuel-syntax--current-vocab)))
+ (when in (setq usings (list in)))
+ (goto-char (point-max))
+ (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)))
+ usings)))
(provide 'fuel-syntax)
From b2c0d4c5be5126c03c87f8cbde4f5a35a02484b0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 15 Dec 2008 18:16:18 -0600
Subject: [PATCH 5/7] Remove old 'bubble-chamber'
---
.../bubble-chamber/bubble-chamber-docs.factor | 84 ------------------
extra/bubble-chamber/bubble-chamber.factor | 88 -------------------
extra/bubble-chamber/common/common.factor | 12 ---
.../particle/axion/axion.factor | 68 --------------
.../particle/hadron/hadron.factor | 59 -------------
.../particle/muon/colors/colors.factor | 53 -----------
.../bubble-chamber/particle/muon/muon.factor | 63 -------------
extra/bubble-chamber/particle/particle.factor | 68 --------------
.../particle/quark/quark.factor | 53 -----------
extra/bubble-chamber/tags.txt | 1 -
10 files changed, 549 deletions(-)
delete mode 100644 extra/bubble-chamber/bubble-chamber-docs.factor
delete mode 100644 extra/bubble-chamber/bubble-chamber.factor
delete mode 100644 extra/bubble-chamber/common/common.factor
delete mode 100644 extra/bubble-chamber/particle/axion/axion.factor
delete mode 100644 extra/bubble-chamber/particle/hadron/hadron.factor
delete mode 100644 extra/bubble-chamber/particle/muon/colors/colors.factor
delete mode 100644 extra/bubble-chamber/particle/muon/muon.factor
delete mode 100644 extra/bubble-chamber/particle/particle.factor
delete mode 100644 extra/bubble-chamber/particle/quark/quark.factor
delete mode 100644 extra/bubble-chamber/tags.txt
diff --git a/extra/bubble-chamber/bubble-chamber-docs.factor b/extra/bubble-chamber/bubble-chamber-docs.factor
deleted file mode 100644
index 72ffb63848..0000000000
--- a/extra/bubble-chamber/bubble-chamber-docs.factor
+++ /dev/null
@@ -1,84 +0,0 @@
-
-USING: help.syntax help.markup ;
-
-USING: bubble-chamber.particle.muon
- bubble-chamber.particle.quark
- bubble-chamber.particle.hadron
- bubble-chamber.particle.axion ;
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: muon
-
- { $class-description
- "The muon is a colorful particle with an entangled friend."
- "It draws both itself and its horizontally symmetric partner."
- "A high range of speed and almost no speed decay allow the"
- "muon to reach the extents of the window, often forming rings"
- "where theta has decayed but speed remains stable. The result"
- "is color almost everywhere in the general direction of collision,"
- "stabilized into fuzzy rings." } ;
-
-HELP: quark
-
- { $class-description
- "The quark draws as a translucent black. Their large numbers"
- "create fields of blackness overwritten only by the glowing shadows of "
- "Hadrons. "
- "quarks are allowed to accelerate away with speed decay values above 1.0. "
- "Each quark has an entangled friend. Both particles are drawn identically,"
- "mirrored along the y-axis." } ;
-
-HELP: hadron
-
- { $class-description
- "Hadrons collide from totally random directions. "
- "Those hadrons that do not exit the drawing area, "
- "tend to stabilize into perfect circular orbits. "
- "Each hadron draws with a slight glowing emboss. "
- "The hadron itself is not drawn." } ;
-
-HELP: axion
-
- { $class-description
- "The axion particle draws a bold black path. Axions exist "
- "in a slightly higher dimension and as such are drawn with "
- "elevated embossed shadows. Axions are quick to stabilize "
- "and fall into single pixel orbits axions automatically "
- "recollide themselves after stabilizing." } ;
-
-{ muon quark hadron axion } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber" "Bubble Chamber"
-
-"The " { $vocab-link "bubble-chamber" }
-" is a generative painting system of imaginary "
-"colliding particles. A single super-massive collision produces a "
-"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures.\n"
-"\n"
-"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique.\n"
- { $subsection muon }
- { $subsection quark }
- { $subsection hadron }
- { $subsection axion }
-"\n"
-"After you run the vocabulary, a window will appear. Click the "
-"mouse in a random area to fire 11 particles of each type. "
-"Another way to fire particles is to press the "
-"spacebar. This fires all the particles.\n"
-"\n"
-"Bubble Chamber was created by Jared Tarbell. "
-"It was originally implemented in Processing. "
-"It was ported to Factor by Eduardo Cavazos. "
-"The original work is on display here: "
-{ $url
-"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-ABOUT: "bubble-chamber"
-
diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor
deleted file mode 100644
index 4b0db46c35..0000000000
--- a/extra/bubble-chamber/bubble-chamber.factor
+++ /dev/null
@@ -1,88 +0,0 @@
-
-USING: kernel namespaces sequences random math math.constants math.libm vars
- ui
- processing
- processing.gadget
- bubble-chamber.common
- bubble-chamber.particle
- bubble-chamber.particle.muon
- bubble-chamber.particle.quark
- bubble-chamber.particle.hadron
- bubble-chamber.particle.axion ;
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VARS: particles muons quarks hadrons axions ;
-
-VAR: boom
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-all ( -- )
-
- 2 pi * 1random >collision-theta
-
- particles> [ collide ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: collide-one ( -- )
-
- dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
-
- hadrons> random collide
- quarks> random collide
- muons> random collide ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse-pressed ( -- )
- boom on
- 1 background ! kludge
- 11 [ drop collide-one ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key-released ( -- )
- key " " =
- [
- boom on
- 1 background
- collide-all
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bubble-chamber ( -- )
-
- 1000 1000 size*
-
- [
- 1 background
- no-stroke
-
- 1789 [ drop <muon> ] map >muons
- 1300 [ drop <quark> ] map >quarks
- 1000 [ drop <hadron> ] map >hadrons
- 111 [ drop <axion> ] map >axions
-
- muons> quarks> hadrons> axions> 3append append >particles
-
- collide-one
- ] setup
-
- [
- boom>
- [ particles> [ move ] each ]
- when
- ] draw
-
- [ mouse-pressed ] button-down
- [ key-released ] key-up ;
-
-: go ( -- ) [ bubble-chamber run ] with-ui ;
-
-MAIN: go
\ No newline at end of file
diff --git a/extra/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor
deleted file mode 100644
index c9ce687535..0000000000
--- a/extra/bubble-chamber/common/common.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-
-USING: kernel math accessors combinators.cleave vars ;
-
-IN: bubble-chamber.common
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: collision-theta
-
-: dim ( -- dim ) 1000 ;
-
-: center ( -- point ) dim 2 / dup {2} ; foldable
diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor
deleted file mode 100644
index 2dafc36cde..0000000000
--- a/extra/bubble-chamber/particle/axion/axion.factor
+++ /dev/null
@@ -1,68 +0,0 @@
-
-USING: kernel sequences random accessors multi-methods
- math math.constants math.ranges math.points combinators.cleave
- processing processing.shapes
- bubble-chamber.common bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.axion
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: axion < particle ;
-
-: <axion> ( -- axion ) axion new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { axion }
-
- center >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
-
-: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
-: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { axion }
-
- { 0.06 0.59 } stroke
- dup pos>> point
-
- 1 4 [a,b] [ axion-white axion-point- ] each
- 1 4 [a,b] [ axion-black axion-point+ ] each
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- 1000 random 996 >
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- 100 random 30 > [ collide ] [ drop ] if
- ]
- [ drop ]
- if ;
diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor
deleted file mode 100644
index 910df97789..0000000000
--- a/extra/bubble-chamber/particle/hadron/hadron.factor
+++ /dev/null
@@ -1,59 +0,0 @@
-
-USING: kernel random math math.constants math.points accessors multi-methods
- processing processing.shapes
- bubble-chamber.common
- bubble-chamber.particle colors ;
-
-IN: bubble-chamber.particle.hadron
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: hadron < particle ;
-
-: <hadron> ( -- hadron ) hadron new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { hadron }
-
- center >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- 0 1 0 1 rgba boa >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { hadron }
-
- { 1 0.11 } stroke
- dup pos>> 1 v-y point
-
- { 0 0.11 } stroke
- dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- 100 random 70 > [ dup collide ] when
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor
deleted file mode 100644
index 644bed833b..0000000000
--- a/extra/bubble-chamber/particle/muon/colors/colors.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-
-USING: kernel sequences math math.constants math.order accessors
- processing
- colors ;
-
-IN: bubble-chamber.particle.muon.colors
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ good-colors at-fraction-of >>myc ]
- [ drop ]
- if ;
-
-: set-anti-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ anti-colors at-fraction-of >>mya ]
- [ drop ]
- if ;
diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor
deleted file mode 100644
index c5ee71c1b0..0000000000
--- a/extra/bubble-chamber/particle/muon/muon.factor
+++ /dev/null
@@ -1,63 +0,0 @@
-
-USING: kernel arrays sequences random
- math
- math.ranges
- math.functions
- math.vectors
- multi-methods accessors
- combinators.cleave
- processing
- processing.shapes
- bubble-chamber.common
- bubble-chamber.particle
- bubble-chamber.particle.muon.colors ;
-
-IN: bubble-chamber.particle.muon
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: muon < particle ;
-
-: <muon> ( -- muon ) muon new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { muon }
-
- center >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- collision-theta> -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
-
- set-good-color
- set-anti-color
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { muon }
-
- dup myc>> 0.16 >>alpha stroke
- dup pos>> point
-
- dup mya>> 0.16 >>alpha stroke
- dup pos>> first2 >r dim swap - r> 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- step-theta
- step-theta-d
- step-speed-sub
-
- out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor
deleted file mode 100644
index 8b13e9b4b7..0000000000
--- a/extra/bubble-chamber/particle/particle.factor
+++ /dev/null
@@ -1,68 +0,0 @@
-
-USING: kernel sequences combinators
- math math.vectors math.functions multi-methods
- accessors combinators.cleave processing
- bubble-chamber.common colors ;
-
-IN: bubble-chamber.particle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 rgba boa >>myc
- 0 0 0 1 rgba boa >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
-
-: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
-: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
-: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x ( particle -- x ) pos>> first ;
-: y ( particle -- x ) pos>> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: out-of-bounds? ( particle -- particle ? )
- dup
- { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
- or or or ;
diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor
deleted file mode 100644
index 194b97a9cd..0000000000
--- a/extra/bubble-chamber/particle/quark/quark.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-
-USING: kernel arrays sequences random math accessors multi-methods
- processing processing.shapes
- bubble-chamber.common
- bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.quark
-
-TUPLE: quark < particle ;
-
-: <quark> ( -- quark ) quark new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { quark }
-
- center >>pos
- collision-theta> -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { quark }
-
- dup myc>> 0.13 >>alpha stroke
- dup pos>> point
-
- dup pos>> first2 >r dim swap - r> 2array point
-
- [ ] [ vel>> ] bi move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
diff --git a/extra/bubble-chamber/tags.txt b/extra/bubble-chamber/tags.txt
deleted file mode 100644
index cb5fc203e1..0000000000
--- a/extra/bubble-chamber/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-demos
From a02cc592c6d9859c7dd984bd330d794edea2ef5d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 15 Dec 2008 18:24:05 -0600
Subject: [PATCH 6/7] remove old 'processing' vocabulary
---
extra/processing/processing.factor | 313 -----------------------------
1 file changed, 313 deletions(-)
delete mode 100644 extra/processing/processing.factor
diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor
deleted file mode 100644
index f351c989f0..0000000000
--- a/extra/processing/processing.factor
+++ /dev/null
@@ -1,313 +0,0 @@
-
-USING: kernel namespaces threads combinators sequences arrays
- math math.functions math.ranges random
- opengl.gl opengl.glu vars multi-methods generalizations shuffle
- ui
- ui.gestures
- ui.gadgets
- combinators
- combinators.lib
- combinators.cleave
- rewrite-closures bake bake.fry accessors newfx
- processing.gadget math.geometry.rect
- processing.shapes
- colors ;
-
-IN: processing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chance ( fraction -- ? ) 0 1 2random > ;
-
-: percent-chance ( percent -- ? ) 100 / chance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * at ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: canonical-color-value ( obj -- color )
-
-METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
-
-METHOD: canonical-color-value { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> rgba boa ] }
- { 3 [ first3 1 rgba boa ] }
- { 4 [ first4 rgba boa ] }
- }
- case ;
-
-! METHOD: canonical-color-value { rgba }
-! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
-
-METHOD: canonical-color-value { color } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill ( value -- ) canonical-color-value >fill-color ;
-: stroke ( value -- ) canonical-color-value >stroke-color ;
-
-! : no-fill ( -- ) 0 fill-color> set-fourth ;
-! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
-
-: no-fill ( -- ) fill-color> 0 >>alpha drop ;
-: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-weight ( w -- ) glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-! GL_POLYGON glBegin
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glEnd ;
-
-! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-
-! 8 ndup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! quad-vertices
-
-! GL_FRONT_AND_BACK GL_LINE glPolygonMode
-! stroke-color> set-color
-
-! quad-vertices ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : ellipse-disk ( x y width height -- )
-! glPushMatrix
-! >r >r
-! 0 glTranslated
-! r> r> 1 glScaled
-! gluNewQuadric
-! dup 0 0.5 20 1 gluDisk
-! gluDeleteQuadric
-! glPopMatrix ;
-
-! : ellipse-center ( x y width height -- )
-
-! 4dup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! stroke-color> set-color
-
-! ellipse-disk
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
-
-! ellipse-disk ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! SYMBOL: CENTER
-! SYMBOL: RADIUS
-! SYMBOL: CORNER
-! SYMBOL: CORNERS
-
-! SYMBOL: ellipse-mode-value
-
-! : ellipse-mode ( val -- ) ellipse-mode-value set ;
-
-! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
-
-! : ellipse-corner ( x y width height -- )
-! [ drop nip 2 / + ] 4keep
-! [ nip rot drop 2 / + ] 4keep
-! [ >r >r 2drop r> r> ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse-corners ( x1 y1 x2 y2 -- )
-! [ drop nip + 2 / ] 4keep
-! [ nip rot drop + 2 / ] 4keep
-! [ drop nip - abs 1+ ] 4keep
-! [ nip rot drop - abs 1+ ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse ( a b c d -- )
-! ellipse-mode-value get
-! {
-! { CENTER [ ellipse-center ] }
-! { RADIUS [ ellipse-radius ] }
-! { CORNER [ ellipse-corner ] }
-! { CORNERS [ ellipse-corners ] }
-! }
-! case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: background ( value -- )
-
-METHOD: background { number }
- dup dup 1 glClearColor
- GL_COLOR_BUFFER_BIT glClear ;
-
-METHOD: background { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: translate ( x y -- ) 0 glTranslated ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: frame-rate-value
-
-: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: slate
-
-VAR: loop-flag
-
-: defaults ( -- )
- 0.8 background
- ! CENTER ellipse-mode
- 60 frame-rate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: size-val
-
-: size ( seq -- ) size-val set ;
-
-: size* ( width height -- ) 2array size-val set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-action
-SYMBOL: draw-action
-
-! : setup ( quot -- ) closed-quot setup-action set ;
-! : draw ( quot -- ) closed-quot draw-action set ;
-
-: setup ( quot -- ) setup-action set ;
-: draw ( quot -- ) draw-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-down-action
-SYMBOL: key-up-action
-
-: key-down ( quot -- ) closed-quot key-down-action set ;
-: key-up ( quot -- ) closed-quot key-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-down-action
-SYMBOL: button-up-action
-
-: button-down ( quot -- ) closed-quot button-down-action set ;
-: button-up ( quot -- ) closed-quot button-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-processing-thread ( -- )
- loop-flag get not
- [
- loop-flag on
- [
- [ loop-flag get ]
- processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
- [ ]
- while
- ]
- in-thread
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-size ( -- size ) processing-gadget get rect-dim ;
-
-: width ( -- width ) get-size first ;
-: height ( -- height ) get-size second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-called
-
-: setup-called? ( -- ? ) setup-called get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run ( -- )
-
- loop-flag off
-
- 500 sleep
-
- <processing-gadget>
- size-val get >>pdim
- dup "Processing" open-window
-
- 500 sleep
-
- defaults
-
- setup-called off
-
- [
- setup-called? not
- [
- setup-action get call
- setup-called on
- ]
- [
- draw-action get call
- ]
- if
- ]
- closed-quot >>action
-
- key-down-action get >>key-down
- key-up-action get >>key-up
-
- button-down-action get >>button-down
- button-up-action get >>button-up
-
- processing-gadget set
-
- start-processing-thread ;
\ No newline at end of file
From a34958661948e25193b43a11062d9355b7186c49 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 15 Dec 2008 18:26:11 -0600
Subject: [PATCH 7/7] Remove 'processing.gadget' (all demos converted to use
standard ui idioms)
---
extra/processing/gadget/gadget.factor | 69 ---------------------------
1 file changed, 69 deletions(-)
delete mode 100644 extra/processing/gadget/gadget.factor
diff --git a/extra/processing/gadget/gadget.factor b/extra/processing/gadget/gadget.factor
deleted file mode 100644
index 0b3bb6dc01..0000000000
--- a/extra/processing/gadget/gadget.factor
+++ /dev/null
@@ -1,69 +0,0 @@
-
-USING: kernel namespaces combinators
- ui.gestures accessors ui.gadgets.frame-buffer ;
-
-IN: processing.gadget
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-
-: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-SYMBOL: key-pressed-value
-
-SYMBOL: button-value
-SYMBOL: key-value
-
-: key-pressed? ( -- ? ) key-pressed-value get ;
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-: key ( -- key ) key-value get ;
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: processing-gadget handle-gesture ( gesture gadget -- ? )
- swap
- {
- {
- [ dup key-down? ]
- [
- sym>> key-value set
- key-pressed-value on
- key-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup key-up? ]
- [
- key-pressed-value off
- drop
- key-up>> dup [ call ] [ drop ] if
- t
- ] }
- {
- [ dup button-down? ]
- [
- #>> button-value set
- mouse-pressed-value on
- button-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup button-up? ]
- [
- mouse-pressed-value off
- drop
- button-up>> dup [ call ] [ drop ] if
- t
- ]
- }
- { [ t ] [ 2drop t ] }
- }
- cond ;