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 ] map >muons - 1300 [ drop ] map >quarks - 1000 [ drop ] map >hadrons - 111 [ drop ] 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 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 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 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 } ] 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 } ] 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 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 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 ; + +[ 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 + +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 '[ _ @ reverse [ write ] each ] ; + +: sprintf ( format-string -- result ) + [ printf ] with-string-writer ; 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 + '[ _ @ 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/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/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." } ; 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 - -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 '[ _ @ reverse [ write ] each ] ; - -: sprintf ( format-string -- result ) - [ printf ] with-string-writer ; inline - - 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 ; - -: ( -- 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 ; 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 / 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 - - - 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 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 ; - -[ 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 be19fb0919..0000000000 --- a/extra/time/time.factor +++ /dev/null @@ -1,72 +0,0 @@ -! 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 ; - -IN: time - -: >timestring ( timestamp -- string ) - [ hour>> ] keep [ minute>> ] keep second>> 3array - [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline - -: >datestring ( timestamp -- string ) - [ month>> ] keep [ day>> ] keep year>> 3array - [ number>string 2 CHAR: 0 pad-left ] map "/" 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 - - - [[ [ "%" ] ]] -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-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-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 - '[ _ @ reverse concat nip ] ; - - 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 +;; 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)