steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-12-15 18:31:12 -06:00
parent b062425935 a349586619
commit 0a85916e3c
37 changed files with 677 additions and 1442 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
extra/bubble-chamber/bubble-chamber-docs.factor
View File

@ -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"

88
extra/bubble-chamber/bubble-chamber.factor
View File

@ -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

12
extra/bubble-chamber/common/common.factor
View File

@ -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

68
extra/bubble-chamber/particle/axion/axion.factor
View File

@ -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 ;

59
extra/bubble-chamber/particle/hadron/hadron.factor
View File

@ -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 ;

53
extra/bubble-chamber/particle/muon/colors/colors.factor
View File

@ -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 ;

63
extra/bubble-chamber/particle/muon/muon.factor
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

68
extra/bubble-chamber/particle/particle.factor
View File

@ -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 ;

53
extra/bubble-chamber/particle/quark/quark.factor
View File

@ -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 ;

1
extra/bubble-chamber/tags.txt
View File

@ -1 +0,0 @@
demos

0
extra/printf/authors.txt → extra/formatting/authors.txt
View File

123
extra/formatting/formatting-docs.factor Normal file
View File

@ -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"

73
extra/printf/printf-tests.factor → extra/formatting/formatting-tests.factor
View File

@ -1,132 +1,97 @@
! Copyright (C) 2008 John Benediktsson ! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license ! 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" printf ] must-infer
[ "%s" sprintf ] must-infer [ "%s" sprintf ] must-infer
[ t ] [ "" "" sprintf = ] unit-test [ t ] [ "" "" sprintf = ] unit-test
[ t ] [ "asdf" "asdf" 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 "%+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 ] [ " -10" -10 "%5d" sprintf = ] unit-test
[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test [ t ] [ "-0010" -10 "%05d" 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 ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test [ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
[ t ] [ "123.10" 123.1 "%01.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.2346" 1.23456789 "%.4f" sprintf = ] unit-test
[ t ] [ " 1.23" 1.23456789 "%6.2f" 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.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 ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
[ t ] [ "3.625e+08" 362525200 "%.3e" 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 ] [ "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 ] [ " -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 ] [ "+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 ] [ "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 ] [ "0F" HEX: f "%02X" sprintf = ] unit-test [ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
[ t ] [ "2008-09-10" [ t ] [ "2008-09-10"
2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
[ t ] [ "Hello, World!" [ t ] [ "Hello, World!"
"Hello, World!" "%s" sprintf = ] unit-test "Hello, World!" "%s" sprintf = ] unit-test
[ t ] [ "printf test" [ t ] [ "printf test"
"printf test" sprintf = ] unit-test "printf test" sprintf = ] unit-test
[ t ] [ "char a = 'a'" [ t ] [ "char a = 'a'"
CHAR: a "char %c = 'a'" sprintf = ] unit-test CHAR: a "char %c = 'a'" sprintf = ] unit-test
[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test [ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test [ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
[ t ] [ "0 message(s)" [ t ] [ "0 message(s)"
0 "message" "%d %s(s)" sprintf = ] unit-test 0 "message" "%d %s(s)" sprintf = ] unit-test
[ t ] [ "0 message(s) with %" [ t ] [ "0 message(s) with %"
0 "message" "%d %s(s) with %%" sprintf = ] unit-test 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
[ t ] [ "justif: \"left \"" [ t ] [ "justif: \"left \""
"left" "justif: \"%-10s\"" sprintf = ] unit-test "left" "justif: \"%-10s\"" sprintf = ] unit-test
[ t ] [ "justif: \" right\"" [ t ] [ "justif: \" right\""
"right" "justif: \"%10s\"" sprintf = ] unit-test "right" "justif: \"%10s\"" sprintf = ] unit-test
[ t ] [ " 3: 0003 zero padded" [ t ] [ " 3: 0003 zero padded"
3 " 3: %04d zero padded" sprintf = ] unit-test 3 " 3: %04d zero padded" sprintf = ] unit-test
[ t ] [ " 3: 3 left justif" [ t ] [ " 3: 3 left justif"
3 " 3: %-4d left justif" sprintf = ] unit-test 3 " 3: %-4d left justif" sprintf = ] unit-test
[ t ] [ " 3: 3 right justif" [ t ] [ " 3: 3 right justif"
3 " 3: %4d right justif" sprintf = ] unit-test 3 " 3: %4d right justif" sprintf = ] unit-test
[ t ] [ " -3: -003 zero padded" [ t ] [ " -3: -003 zero padded"
-3 " -3: %04d zero padded" sprintf = ] unit-test -3 " -3: %04d zero padded" sprintf = ] unit-test
[ t ] [ " -3: -3 left justif" [ t ] [ " -3: -3 left justif"
-3 " -3: %-4d left justif" sprintf = ] unit-test -3 " -3: %-4d left justif" sprintf = ] unit-test
[ t ] [ " -3: -3 right justif" [ t ] [ " -3: -3 right justif"
-3 " -3: %4d right justif" sprintf = ] unit-test -3 " -3: %4d right justif" sprintf = ] unit-test
[ t ] [ "There are 10 monkeys in the kitchen" [ t ] [ "There are 10 monkeys in the kitchen"
10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
[ f ] [ "%d" 10 "%d" sprintf = ] unit-test [ f ] [ "%d" 10 "%d" sprintf = ] unit-test
[ t ] [ "[monkey]" "monkey" "[%s]" 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 ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test [ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test [ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test [ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
[ t ] [ "[many monke]" "many monkeys" "[%10.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

186
extra/formatting/formatting.factor Normal file
View File

@ -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 ] ;

0
extra/printf/summary.txt → extra/formatting/summary.txt
View File

39
extra/fuel/fuel.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2008 Jose Antonio Ortega Ruiz. ! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes classes.tuple compiler.units USING: accessors arrays assocs classes classes.tuple
combinators continuations debugger definitions eval help io combinators compiler.units continuations debugger definitions
io.files io.pathnames io.streams.string kernel lexer listener eval help io io.files io.pathnames io.streams.string kernel
listener.private make math namespaces parser prettyprint lexer listener listener.private make math memoize namespaces
prettyprint.config quotations sequences strings source-files parser prettyprint prettyprint.config quotations sequences sets
tools.vocabs vectors vocabs vocabs.loader ; sorting source-files strings tools.vocabs vectors vocabs
vocabs.loader ;
IN: fuel IN: fuel
@ -88,6 +89,14 @@ SYMBOL: :restarts
M: condition fuel-pprint M: condition fuel-pprint
[ error>> ] [ fuel-restarts ] bi 2array condition prefix 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 M: source-file-error fuel-pprint
[ file>> ] [ error>> ] bi 2array source-file-error prefix [ file>> ] [ error>> ] bi 2array source-file-error prefix
fuel-pprint ; fuel-pprint ;
@ -159,8 +168,24 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-get-vocab-location ( vocab -- ) : fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ; >vocab-link fuel-get-edit-location ;
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
: fuel-get-vocabs ( -- ) : 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 : fuel-run-file ( path -- ) run-file ; inline

2
extra/math/binpack/binpack-docs.factor
View File

@ -15,5 +15,5 @@ HELP: binpack*
HELP: binpack! HELP: binpack!
{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } } { $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." } ;

80
extra/printf/printf-docs.factor
View File

@ -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"

112
extra/printf/printf.factor
View File

@ -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

69
extra/processing/gadget/gadget.factor
View File

@ -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 ;

313
extra/processing/processing.factor
View File

@ -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 ;

1
extra/time/authors.txt
View File

@ -1 +0,0 @@
John Benediktsson

43
extra/time/time-docs.factor
View File

@ -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"

24
extra/time/time-tests.factor
View File

@ -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

72
extra/time/time.factor
View File

@ -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
<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" => [[ [ "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
'[ _ <vector> @ reverse concat nip ] ;

1
misc/fuel/README
View File

@ -56,6 +56,7 @@ the same as C-cz)).
- C-co : cycle between code, tests and docs factor files - C-co : cycle between code, tests and docs factor files
- M-. : edit word at point in Emacs (also in listener) - M-. : edit word at point in Emacs (also in listener)
- M-TAB : complete word at point
- C-cC-ev : edit vocabulary - C-cC-ev : edit vocabulary
- C-cr, C-cC-er : eval region - C-cr, C-cC-er : eval region

3
misc/fuel/factor-mode.el
View File

@ -84,8 +84,7 @@ code in the buffer."
(set (make-local-variable 'beginning-of-defun-function) (set (make-local-variable 'beginning-of-defun-function)
'fuel-syntax--beginning-of-defun) 'fuel-syntax--beginning-of-defun)
(set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-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) (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil))
(fuel-syntax--enable-usings))
;;; Indentation: ;;; Indentation:

7
misc/fuel/fuel-base.el
View File

@ -61,5 +61,12 @@
(defsubst empty-string-p (str) (equal str "")) (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) (provide 'fuel-base)
;;; fuel-base.el ends here ;;; fuel-base.el ends here

173
misc/fuel/fuel-completion.el Normal file
View File

@ -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

57
misc/fuel/fuel-connection.el
View File

@ -74,10 +74,11 @@
(defsubst fuel-con--make-connection (buffer) (defsubst fuel-con--make-connection (buffer)
(list :fuel-connection (list :fuel-connection
(list :requests) (cons :requests (list))
(list :current) (cons :current nil)
(cons :completed (make-hash-table :weakness 'value)) (cons :completed (make-hash-table :weakness 'value))
(cons :buffer buffer))) (cons :buffer buffer)
(cons :timer nil)))
(defsubst fuel-con--connection-p (c) (defsubst fuel-con--connection-p (c)
(and (listp c) (eq (car c) :fuel-connection))) (and (listp c) (eq (car c) :fuel-connection)))
@ -110,6 +111,15 @@
(fuel-con--connection-pop-request c) (fuel-con--connection-pop-request c)
(cdr current)))) (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: ;;; Connection setup:
@ -117,7 +127,9 @@
(set-buffer buffer) (set-buffer buffer)
(let ((conn (fuel-con--make-connection buffer))) (let ((conn (fuel-con--make-connection buffer)))
(fuel-con--setup-comint) (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 () (defun fuel-con--setup-comint ()
(add-hook 'comint-redirect-filter-functions (add-hook 'comint-redirect-filter-functions
@ -133,13 +145,13 @@
(let* ((buffer (fuel-con--connection-buffer con)) (let* ((buffer (fuel-con--connection-buffer con))
(req (fuel-con--connection-pop-request con)) (req (fuel-con--connection-pop-request con))
(str (and req (fuel-con--request-string req)))) (str (and req (fuel-con--request-string req))))
(when (and buffer req str) (if (not (buffer-live-p buffer))
(set-buffer buffer) (fuel-con--connection-cancel-timer con)
(when fuel-log--verbose-p (when (and buffer req str)
(with-current-buffer (fuel-log--buffer) (set-buffer buffer)
(let ((inhibit-read-only t)) (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
(fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)))) (comint-redirect-send-command (format "%s" str)
(comint-redirect-send-command str (fuel-log--buffer) nil t))))) (fuel-log--buffer) nil t))))))
(defun fuel-con--process-completed-request (req) (defun fuel-con--process-completed-request (req)
(let ((str (fuel-con--request-output req)) (let ((str (fuel-con--request-output req))
@ -155,7 +167,7 @@
(funcall cont str) (funcall cont str)
(fuel-log--info "<%s>: processed\n\t%s" id str)) (fuel-log--info "<%s>: processed\n\t%s" id str))
(error (fuel-log--error "<%s>: continuation failed %S \n\t%s" (error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
id rstr cerr)))))) id rstr cerr))))))
(defun fuel-con--comint-redirect-filter (str) (defun fuel-con--comint-redirect-filter (str)
(if (not fuel-con--connection) (if (not fuel-con--connection)
@ -164,7 +176,7 @@
(if (not req) (fuel-log--error "No current request (%s)" str) (if (not req) (fuel-log--error "No current request (%s)" str)
(fuel-con--request-output req str) (fuel-con--request-output req str)
(fuel-log--info "<%s>: in progress" (fuel-con--request-id req))))) (fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
".") (fuel--shorten-str str 70))
(defun fuel-con--comint-redirect-hook () (defun fuel-con--comint-redirect-hook ()
(if (not fuel-con--connection) (if (not fuel-con--connection)
@ -193,15 +205,18 @@
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf) (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
(save-current-buffer (save-current-buffer
(let* ((con (fuel-con--get-connection buffer/proc)) (let* ((con (fuel-con--get-connection buffer/proc))
(req (fuel-con--send-string buffer/proc str cont sbuf)) (req (fuel-con--send-string buffer/proc str cont sbuf))
(id (and req (fuel-con--request-id req))) (id (and req (fuel-con--request-id req)))
(time (or timeout fuel-connection-timeout)) (time (or timeout fuel-connection-timeout))
(step 2)) (step 100)
(waitsecs (/ step 1000.0)))
(when id (when id
(while (and (> time 0) (condition-case nil
(not (fuel-con--connection-completed-p con id))) (while (and (> time 0)
(sleep-for 0 step) (not (fuel-con--connection-completed-p con id)))
(setq time (- time step))) (accept-process-output nil waitsecs)
(setq time (- time step)))
(error (setq time 1)))
(or (> time 0) (or (> time 0)
(fuel-con--request-deactivate req) (fuel-con--request-deactivate req)
nil))))) nil)))))

3
misc/fuel/fuel-debug.el
View File

@ -119,6 +119,7 @@
(setq fuel-debug--last-ret ret) (setq fuel-debug--last-ret ret)
(setq fuel-debug--file file) (setq fuel-debug--file file)
(goto-char (point-max)) (goto-char (point-max))
(font-lock-fontify-buffer)
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer)) (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
(not err)))) (not err))))
@ -130,7 +131,7 @@
(trail (and last (substring-no-properties last (/ llen 2)))) (trail (and last (substring-no-properties last (/ llen 2))))
(err (fuel-eval--retort-error ret)) (err (fuel-eval--retort-error ret))
(p (point))) (p (point)))
(save-excursion (insert current)) (when current (save-excursion (insert current)))
(when (and (> clen llen) (> llen 0) (search-forward trail nil t)) (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
(delete-region p (point))) (delete-region p (point)))
(goto-char (point-max)) (goto-char (point-max))

4
misc/fuel/fuel-eval.el
View File

@ -17,6 +17,8 @@
(require 'fuel-syntax) (require 'fuel-syntax)
(require 'fuel-connection) (require 'fuel-connection)
(eval-when-compile (require 'cl))
;;; Simple sexp-based representation of factor code ;;; Simple sexp-based representation of factor code
@ -39,7 +41,7 @@
(:rs 'fuel-eval-restartable) (:rs 'fuel-eval-restartable)
(:nrs 'fuel-eval-non-restartable) (:nrs 'fuel-eval-non-restartable)
(:in (fuel-syntax--current-vocab)) (:in (fuel-syntax--current-vocab))
(:usings `(:array ,@(fuel-syntax--usings-update))) (:usings `(:array ,@(fuel-syntax--usings)))
(:get 'fuel-eval-set-result) (:get 'fuel-eval-set-result)
(t `(:factor ,(symbol-name sexp)))))) (t `(:factor ,(symbol-name sexp))))))
((symbolp sexp) (symbol-name sexp)))) ((symbolp sexp) (symbol-name sexp))))

6
misc/fuel/fuel-help.el
View File

@ -73,7 +73,7 @@
(defun fuel-help--word-synopsis (&optional word) (defun fuel-help--word-synopsis (&optional word)
(let ((word (or word (fuel-syntax-symbol-at-point))) (let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-eval--log t)) (fuel-log--inhibit-p t))
(when word (when word
(let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t)) (let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
(ret (fuel-eval--send/wait cmd 20))) (ret (fuel-eval--send/wait cmd 20)))
@ -157,7 +157,7 @@ displayed in the minibuffer."
(defun fuel-help--show-help-cont (def ret) (defun fuel-help--show-help-cont (def ret)
(let ((out (fuel-eval--retort-output ret))) (let ((out (fuel-eval--retort-output ret)))
(if (or (fuel-eval--retort-error ret) (empty-string-p out)) (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)))) (fuel-help--insert-contents def out))))
(defun fuel-help--insert-contents (def str &optional nopush) (defun fuel-help--insert-contents (def str &optional nopush)
@ -225,6 +225,8 @@ buffer."
(define-key map "q" 'bury-buffer) (define-key map "q" 'bury-buffer)
(define-key map "b" 'fuel-help-previous) (define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next) (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 "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down) (define-key map (kbd "S-SPC") 'scroll-down)
map)) map))

58
misc/fuel/fuel-listener.el
View File

@ -49,9 +49,16 @@ buffer."
;;; Fuel listener buffer/process: ;;; Fuel listener buffer/process:
(defvar fuel-listener-buffer nil (defvar fuel-listener--buffer nil
"The buffer in which the Factor listener is running.") "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 () (defun fuel-listener--start-process ()
(let ((factor (expand-file-name fuel-listener-factor-binary)) (let ((factor (expand-file-name fuel-listener-factor-binary))
(image (expand-file-name fuel-listener-factor-image))) (image (expand-file-name fuel-listener-factor-image)))
@ -59,19 +66,18 @@ buffer."
(error "Could not run factor: %s is not executable" factor)) (error "Could not run factor: %s is not executable" factor))
(unless (file-readable-p image) (unless (file-readable-p image)
(error "Could not run factor: image file %s not readable" image)) (error "Could not run factor: image file %s not readable" image))
(setq fuel-listener-buffer (get-buffer-create "*fuel listener*")) (message "Starting FUEL listener ...")
(with-current-buffer fuel-listener-buffer (comint-exec (fuel-listener--buffer) "factor"
(fuel-listener-mode) factor nil `("-run=fuel" ,(format "-i=%s" image)))
(message "Starting FUEL listener ...") (pop-to-buffer (fuel-listener--buffer))
(comint-exec fuel-listener-buffer "factor" (goto-char (point-max))
factor nil `("-run=fuel" ,(format "-i=%s" image))) (comint-send-string nil "USE: fuel \"\\nFUEL loaded\\n\" write\n")
(fuel-listener--wait-for-prompt 20) (fuel-listener--wait-for-prompt 30)
(fuel-eval--send/wait "USE: fuel") (message "FUEL listener up and running!")))
(message "FUEL listener up and running!"))))
(defun fuel-listener--process (&optional start) (defun fuel-listener--process (&optional start)
(or (and (buffer-live-p fuel-listener-buffer) (or (and (buffer-live-p (fuel-listener--buffer))
(get-buffer-process fuel-listener-buffer)) (get-buffer-process (fuel-listener--buffer)))
(if (not start) (if (not start)
(error "No running factor listener (try M-x run-factor)") (error "No running factor listener (try M-x run-factor)")
(fuel-listener--start-process) (fuel-listener--start-process)
@ -83,18 +89,17 @@ buffer."
;;; Prompt chasing ;;; Prompt chasing
(defun fuel-listener--wait-for-prompt (&optional timeout) (defun fuel-listener--wait-for-prompt (&optional timeout)
(let ((proc (get-buffer-process fuel-listener-buffer))) (let ((proc (get-buffer-process (fuel-listener--buffer)))
(with-current-buffer fuel-listener-buffer (seen))
(goto-char (or comint-last-input-end (point-min))) (with-current-buffer (fuel-listener--buffer)
(let ((seen (re-search-forward comint-prompt-regexp nil t))) (goto-char (or comint-last-input-end (point-max)))
(while (and (not seen) (while (and (not seen)
(accept-process-output proc (or timeout 10) nil t)) (accept-process-output proc (or timeout 10) nil t))
(sleep-for 0 1) (sleep-for 0 1)
(goto-char comint-last-input-end) (goto-char comint-last-input-end)
(setq seen (re-search-forward comint-prompt-regexp nil t))) (setq seen (re-search-forward comint-prompt-regexp nil t)))
(pop-to-buffer fuel-listener-buffer) (goto-char (point-max))
(goto-char (point-max)) (unless seen (error "No prompt found!")))))
(unless seen (error "No prompt found!"))))))
;;; Interface: starting fuel listener ;;; Interface: starting fuel listener
@ -114,13 +119,12 @@ buffer."
;;; Fuel listener mode: ;;; Fuel listener mode:
(defconst fuel-listener--prompt-regex "( [^)]* ) ") (defconst fuel-listener--prompt-regex ".* ) ")
(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener" (define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
"Major mode for interacting with an inferior Factor listener process. "Major mode for interacting with an inferior Factor listener process.
\\{fuel-listener-mode-map}" \\{fuel-listener-mode-map}"
(set (make-local-variable 'comint-prompt-regexp) (set (make-local-variable 'comint-prompt-regexp) fuel-listener--prompt-regex)
fuel-listener--prompt-regex)
(set (make-local-variable 'comint-prompt-read-only) t) (set (make-local-variable 'comint-prompt-read-only) t)
(setq fuel-listener--compilation-begin nil)) (setq fuel-listener--compilation-begin nil))

17
misc/fuel/fuel-log.el
View File

@ -31,6 +31,9 @@
(defvar fuel-log--verbose-p t (defvar fuel-log--verbose-p t
"Log level for Factor messages") "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" (define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages"
"Simple mode to log interactions with the factor listener" "Simple mode to log interactions with the factor listener"
(kill-all-local-variables) (kill-all-local-variables)
@ -52,11 +55,12 @@
(current-buffer)))) (current-buffer))))
(defun fuel-log--msg (type &rest args) (defun fuel-log--msg (type &rest args)
(with-current-buffer (fuel-log--buffer) (unless fuel-log--inhibit-p
(let ((inhibit-read-only t)) (with-current-buffer (fuel-log--buffer)
(insert (let ((inhibit-read-only t))
(fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args)) (insert
fuel-log--max-message-size))))) (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args))
fuel-log--max-message-size))))))
(defsubst fuel-log--warn (&rest args) (defsubst fuel-log--warn (&rest args)
(apply 'fuel-log--msg 'WARNING args)) (apply 'fuel-log--msg 'WARNING args))
@ -65,7 +69,8 @@
(apply 'fuel-log--msg 'ERROR args)) (apply 'fuel-log--msg 'ERROR args))
(defsubst fuel-log--info (&rest 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) (provide 'fuel-log)

44
misc/fuel/fuel-mode.el
View File

@ -21,6 +21,7 @@
(require 'fuel-debug) (require 'fuel-debug)
(require 'fuel-help) (require 'fuel-help)
(require 'fuel-eval) (require 'fuel-eval)
(require 'fuel-completion)
(require 'fuel-listener) (require 'fuel-listener)
@ -67,13 +68,12 @@ buffer in case of errors."
(interactive "r\nP") (interactive "r\nP")
(let* ((lines (split-string (buffer-substring-no-properties begin end) (let* ((lines (split-string (buffer-substring-no-properties begin end)
"[\f\n\r\v]+" t)) "[\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-debug--display-retort
(fuel-eval--send/wait cmd 10000) (fuel-eval--send/wait cmd 10000)
(format "%s%s" (format "%s%s"
(if fuel-syntax--current-vocab (if cv (format "IN: %s " cv) "")
(format "IN: %s " fuel-syntax--current-vocab)
"")
(fuel--shorten-region begin end 70)) (fuel--shorten-region begin end 70))
arg arg
(buffer-file-name)))) (buffer-file-name))))
@ -125,23 +125,24 @@ With prefix, asks for the word to edit."
(let ((cmd `(:fuel ((:quote ,word) fuel-get-edit-location)))) (let ((cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
(condition-case nil (condition-case nil
(fuel--try-edit (fuel-eval--send/wait cmd)) (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) (defvar fuel--vocabs-prompt-history nil)
(defun fuel--read-vocabulary-name () (defun fuel--read-vocabulary-name (refresh)
(let* ((cmd '(:fuel* (fuel-get-vocabs) "fuel" t)) (let* ((vocabs (fuel-completion--vocabs refresh))
(vocabs (fuel-eval--retort-result (fuel-eval--send/wait cmd)))
(prompt "Vocabulary name: ")) (prompt "Vocabulary name: "))
(if vocabs (if vocabs
(completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history) (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
(read-string prompt 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. "Visits vocabulary file in Emacs.
When called interactively, asks for vocabulary with completion." When called interactively, asks for vocabulary with completion.
(interactive (list (fuel--read-vocabulary-name))) With prefix argument, refreshes cached vocabulary list."
(let* ((cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) (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)))) (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)) (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
(fuel-mode--key-1 ?z 'run-factor) (fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?k 'fuel-run-file) (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) (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) (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 "\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 ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?d 'fuel-help) (fuel-mode--key ?d ?d 'fuel-help)

60
misc/fuel/fuel-syntax.el
View File

@ -22,11 +22,17 @@
(while (eq (char-before) ?:) (backward-char)) (while (eq (char-before) ?:) (backward-char))
(skip-syntax-backward "w_")) (skip-syntax-backward "w_"))
(defsubst fuel-syntax--symbol-start ()
(save-excursion (fuel-syntax--beginning-of-symbol) (point)))
(defun fuel-syntax--end-of-symbol () (defun fuel-syntax--end-of-symbol ()
"Move point to the end of the current symbol." "Move point to the end of the current symbol."
(skip-syntax-forward "w_") (skip-syntax-forward "w_")
(while (looking-at ":") (forward-char))) (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 'end-op 'fuel-syntax--end-of-symbol)
(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-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)))) (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
(and (> (length s) 0) s))) (and (> (length s) 0) s)))
;;; Regexps galore: ;;; Regexps galore:
@ -43,7 +50,7 @@
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{" "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"IN:" "INSTANCE:" "INTERSECTION:" "IN:" "INSTANCE:" "INTERSECTION:"
"M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:" "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:" "TUPLE:" "T{" "t\\??" "TYPEDEF:"
@ -91,7 +98,7 @@
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
(defconst fuel-syntax--definition-starters-regex (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 (defconst fuel-syntax--definition-start-regex
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
@ -234,18 +241,13 @@
;;; USING/IN: ;;; 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 () (defun fuel-syntax--current-vocab ()
(let ((ip (let* ((vocab)
(save-excursion (ip
(when (re-search-backward fuel-syntax--current-vocab-regex nil t) (save-excursion
(setq fuel-syntax--current-vocab (match-string-no-properties 1)) (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
(point))))) (setq vocab (match-string-no-properties 1))
(point)))))
(when ip (when ip
(let ((pp (save-excursion (let ((pp (save-excursion
(when (re-search-backward fuel-syntax--sub-vocab-regex ip t) (when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
@ -253,29 +255,19 @@
(when (and pp (> pp ip)) (when (and pp (> pp ip))
(let ((sub (match-string-no-properties 1))) (let ((sub (match-string-no-properties 1)))
(unless (save-excursion (search-backward (format "%s>" sub) pp t)) (unless (save-excursion (search-backward (format "%s>" sub) pp t))
(setq fuel-syntax--current-vocab (setq vocab (format "%s.%s" vocab (downcase sub))))))))
(format "%s.%s" fuel-syntax--current-vocab (downcase sub))))))))) vocab))
fuel-syntax--current-vocab)
(defun fuel-syntax--usings-update () (defun fuel-syntax--usings ()
(save-excursion (save-excursion
(let ((in (fuel-syntax--current-vocab))) (let ((usings)
(setq fuel-syntax--usings (and in (list in)))) (in (fuel-syntax--current-vocab)))
(while (re-search-backward fuel-syntax--using-lines-regex nil t) (when in (setq usings (list in)))
(dolist (u (split-string (match-string-no-properties 1) nil t)) (goto-char (point-max))
(push u fuel-syntax--usings))) (while (re-search-backward fuel-syntax--using-lines-regex nil t)
fuel-syntax--usings)) (dolist (u (split-string (match-string-no-properties 1) nil t))
(push u usings)))
(defsubst fuel-syntax--usings-update-hook () usings)))
(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)))
(provide 'fuel-syntax) (provide 'fuel-syntax)