Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
1e78473da7
|
|
@ -0,0 +1,448 @@
|
|||
|
||||
USING: accessors arrays assocs colors combinators.short-circuit
|
||||
kernel locals math math.functions math.matrices math.order
|
||||
math.parser math.trig math.vectors opengl opengl.demo-support
|
||||
opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
IN: L-system
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <turtle> pos ori angle length thickness color vertices saved ;
|
||||
|
||||
DEFER: default-L-parser-values
|
||||
|
||||
: reset-turtle ( turtle -- turtle )
|
||||
{ 0 0 0 } clone >>pos
|
||||
3 identity-matrix >>ori
|
||||
V{ } clone >>vertices
|
||||
V{ } clone >>saved
|
||||
|
||||
default-L-parser-values ;
|
||||
|
||||
: turtle ( -- turtle ) <turtle> new reset-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: step-turtle ( TURTLE LENGTH -- turtle )
|
||||
|
||||
TURTLE
|
||||
TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+
|
||||
>>pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: Rx ( ANGLE -- Rx )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { 1 0 0 }
|
||||
{ 0 A B }
|
||||
{ 0 C D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Ry ( ANGLE -- Ry )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin ]
|
||||
C [ ANGLE sin neg ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A 0 B }
|
||||
{ 0 1 0 }
|
||||
{ C 0 D } }
|
||||
|
||||
] ] ;
|
||||
|
||||
:: Rz ( ANGLE -- Rz )
|
||||
|
||||
[let | ANGLE [ ANGLE deg>rad ] |
|
||||
|
||||
[let | A [ ANGLE cos ]
|
||||
B [ ANGLE sin neg ]
|
||||
C [ ANGLE sin ]
|
||||
D [ ANGLE cos ] |
|
||||
|
||||
{ { A B 0 }
|
||||
{ C D 0 }
|
||||
{ 0 0 1 } }
|
||||
|
||||
] ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: apply-rotation ( TURTLE ROTATION -- turtle )
|
||||
|
||||
TURTLE TURTLE ori>> ROTATION m. >>ori ;
|
||||
|
||||
: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ;
|
||||
: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ;
|
||||
: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: pitch-up ( turtle angle -- turtle ) neg rotate-x ;
|
||||
: pitch-down ( turtle angle -- turtle ) rotate-x ;
|
||||
|
||||
: turn-left ( turtle angle -- turtle ) rotate-y ;
|
||||
: turn-right ( turtle angle -- turtle ) neg rotate-y ;
|
||||
|
||||
: roll-left ( turtle angle -- turtle ) neg rotate-z ;
|
||||
: roll-right ( turtle angle -- turtle ) rotate-z ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: V ( -- V ) { 0 1 0 } ;
|
||||
|
||||
: X ( turtle -- 3array ) ori>> [ first ] map ;
|
||||
: Y ( turtle -- 3array ) ori>> [ second ] map ;
|
||||
: Z ( turtle -- 3array ) ori>> [ third ] map ;
|
||||
|
||||
: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ;
|
||||
: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ;
|
||||
: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ;
|
||||
|
||||
:: roll-until-horizontal ( TURTLE -- turtle )
|
||||
|
||||
TURTLE
|
||||
|
||||
V TURTLE Z cross normalize set-X
|
||||
|
||||
TURTLE Z TURTLE X cross normalize set-Y ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: strafe-up ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ;
|
||||
|
||||
:: strafe-down ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ;
|
||||
|
||||
:: strafe-left ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ;
|
||||
|
||||
:: strafe-right ( TURTLE LENGTH -- turtle )
|
||||
TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ;
|
||||
|
||||
: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ;
|
||||
|
||||
: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ;
|
||||
|
||||
: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ;
|
||||
|
||||
: draw-forward ( turtle length -- turtle )
|
||||
GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ;
|
||||
|
||||
: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ;
|
||||
|
||||
: sneak-forward ( turtle length -- turtle ) step-turtle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: scale-length ( turtle m -- turtle ) over length>> * >>length ;
|
||||
: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ;
|
||||
|
||||
: scale-thickness ( turtle m -- turtle )
|
||||
over thickness>> * 0.5 max set-thickness ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: color-table ( -- colors )
|
||||
{
|
||||
T{ rgba f 0 0 0 1 } ! black
|
||||
T{ rgba f 0.5 0.5 0.5 1 } ! grey
|
||||
T{ rgba f 1 0 0 1 } ! red
|
||||
T{ rgba f 1 1 0 1 } ! yellow
|
||||
T{ rgba f 0 1 0 1 } ! green
|
||||
T{ rgba f 0.25 0.88 0.82 1 } ! turquoise
|
||||
T{ rgba f 0 0 1 1 } ! blue
|
||||
T{ rgba f 0.63 0.13 0.94 1 } ! purple
|
||||
T{ rgba f 0.00 0.50 0.00 1 } ! dark green
|
||||
T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise
|
||||
T{ rgba f 0.00 0.00 0.50 1 } ! dark blue
|
||||
T{ rgba f 0.58 0.00 0.82 1 } ! dark purple
|
||||
T{ rgba f 0.50 0.00 0.00 1 } ! dark red
|
||||
T{ rgba f 0.25 0.25 0.25 1 } ! dark grey
|
||||
T{ rgba f 0.75 0.75 0.75 1 } ! medium grey
|
||||
T{ rgba f 1 1 1 1 } ! white
|
||||
} ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : material-color ( color -- )
|
||||
! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ;
|
||||
|
||||
: material-color ( color -- )
|
||||
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ;
|
||||
|
||||
: set-color ( turtle i -- turtle )
|
||||
dup color-table nth dup gl-color material-color >>color ;
|
||||
|
||||
: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: save-turtle ( turtle -- turtle ) dup clone over saved>> push ;
|
||||
: restore-turtle ( turtle -- turtle ) saved>> pop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: default-L-parser-values ( turtle -- turtle )
|
||||
1 >>length 45 >>angle 1 >>thickness 2 >>color ;
|
||||
|
||||
: L-parser-dialect ( -- commands )
|
||||
|
||||
{
|
||||
{ "+" [ dup angle>> turn-left ] }
|
||||
{ "-" [ dup angle>> turn-right ] }
|
||||
{ "&" [ dup angle>> pitch-down ] }
|
||||
{ "^" [ dup angle>> pitch-up ] }
|
||||
{ "<" [ dup angle>> roll-left ] }
|
||||
{ ">" [ dup angle>> roll-right ] }
|
||||
|
||||
{ "|" [ 180.0 rotate-y ] }
|
||||
{ "%" [ 180.0 rotate-z ] }
|
||||
{ "$" [ roll-until-horizontal ] }
|
||||
|
||||
{ "F" [ dup length>> draw-forward ] }
|
||||
{ "Z" [ dup length>> 2 / draw-forward ] }
|
||||
{ "f" [ dup length>> move-forward ] }
|
||||
{ "z" [ dup length>> 2 / move-forward ] }
|
||||
{ "g" [ dup length>> sneak-forward ] }
|
||||
{ "." [ polygon-vertex ] }
|
||||
|
||||
{ "[" [ save-turtle ] }
|
||||
{ "]" [ restore-turtle ] }
|
||||
|
||||
{ "{" [ start-polygon ] }
|
||||
{ "}" [ finish-polygon ] }
|
||||
|
||||
{ "/" [ 1.1 scale-length ] } ! double quote command in lparser
|
||||
{ "'" [ 0.9 scale-length ] }
|
||||
{ ";" [ 1.1 scale-angle ] }
|
||||
{ ":" [ 0.9 scale-angle ] }
|
||||
{ "?" [ 1.4 scale-thickness ] }
|
||||
{ "!" [ 0.7 scale-thickness ] }
|
||||
|
||||
{ "c" [ dup color>> 1 + color-table length mod set-color ] }
|
||||
|
||||
}
|
||||
;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <L-system> < gadget
|
||||
camera display-list
|
||||
commands axiom rules string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: open-paren ( -- ch ) CHAR: ( ;
|
||||
: close-paren ( -- ch ) CHAR: ) ;
|
||||
|
||||
: open-paren? ( obj -- ? ) open-paren = ;
|
||||
: close-paren? ( obj -- ? ) close-paren = ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: read-instruction ( STRING -- next rest )
|
||||
|
||||
{ [ STRING length 1 > ] [ STRING second open-paren? ] } 0&&
|
||||
[ STRING close-paren STRING index 1 + cut ]
|
||||
[ STRING 1 cut ]
|
||||
if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string-loop ( STRING RULES ACCUM -- )
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
NEXT 1 head RULES at NEXT or ACCUM push-all
|
||||
|
||||
REST RULES ACCUM iterate-string-loop ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-string ( STRING RULES -- string )
|
||||
|
||||
[let | ACCUM [ STRING length 10 * <sbuf> ] |
|
||||
|
||||
STRING RULES ACCUM iterate-string-loop
|
||||
|
||||
ACCUM >string ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: interpret-string ( STRING COMMANDS -- )
|
||||
|
||||
STRING empty? not
|
||||
[
|
||||
STRING read-instruction
|
||||
|
||||
[let | REST [ ] NEXT [ ] |
|
||||
|
||||
[let | COMMAND [ NEXT 1 head COMMANDS at ] |
|
||||
|
||||
COMMAND
|
||||
[
|
||||
NEXT length 1 =
|
||||
[ COMMAND call ]
|
||||
[
|
||||
NEXT 2 tail 1 head* string>number
|
||||
COMMAND 1 tail*
|
||||
call
|
||||
]
|
||||
if
|
||||
]
|
||||
when ]
|
||||
|
||||
REST COMMANDS interpret-string ]
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: iterate-L-system-string ( L-SYSTEM -- )
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM rules>>
|
||||
iterate-string
|
||||
L-SYSTEM (>>string) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: do-camera-look-at ( CAMERA -- )
|
||||
|
||||
[let | EYE [ CAMERA pos>> ]
|
||||
FOCUS [ CAMERA clone 1 step-turtle pos>> ]
|
||||
UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ]
|
||||
|
|
||||
|
||||
EYE FOCUS UP gl-look-at ] ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: generate-display-list ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
L-SYSTEM display-list>> GL_COMPILE glNewList
|
||||
|
||||
turtle
|
||||
L-SYSTEM string>>
|
||||
L-SYSTEM commands>>
|
||||
interpret-string
|
||||
drop
|
||||
|
||||
glEndList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> draw-gadget* ( L-SYSTEM -- )
|
||||
|
||||
black gl-clear
|
||||
|
||||
GL_FLAT glShadeModel
|
||||
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
-1 1 -1 1 1.5 200 glFrustum
|
||||
|
||||
GL_MODELVIEW glMatrixMode
|
||||
|
||||
glLoadIdentity
|
||||
|
||||
L-SYSTEM camera>> do-camera-look-at
|
||||
|
||||
GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
|
||||
! draw axis
|
||||
white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd
|
||||
|
||||
L-SYSTEM display-list>> glCallList ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> graft* ( L-SYSTEM -- )
|
||||
|
||||
L-SYSTEM find-gl-context
|
||||
|
||||
1 glGenLists L-SYSTEM (>>display-list) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <L-system> pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: camera-left ( L-SYSTEM -- )
|
||||
L-SYSTEM camera>> 5 turn-left drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: with-camera ( L-SYSTEM QUOT -- )
|
||||
L-SYSTEM camera>> QUOT call drop
|
||||
L-SYSTEM relayout-1 ;
|
||||
|
||||
<L-system>
|
||||
H{
|
||||
{ T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] }
|
||||
{ T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] }
|
||||
{ T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] }
|
||||
{ T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] }
|
||||
|
||||
{ T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] }
|
||||
{ T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] }
|
||||
|
||||
{
|
||||
T{ key-down f f "x" }
|
||||
[
|
||||
dup iterate-L-system-string
|
||||
dup generate-display-list
|
||||
dup relayout-1
|
||||
drop
|
||||
]
|
||||
}
|
||||
|
||||
}
|
||||
set-gestures
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: L-system ( -- L-system )
|
||||
|
||||
<L-system> new-gadget
|
||||
|
||||
turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
|
||||
USING: accessors kernel ui L-system ;
|
||||
|
||||
IN: L-system.models.abop-1
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: abop-1 ( <L-system> -- <L-system> )
|
||||
|
||||
L-parser-dialect >>commands
|
||||
|
||||
"c(12)FFAL" >>axiom
|
||||
|
||||
{
|
||||
{ "A" "F[&'(.8)!BL]>(137)'!(.9)A" }
|
||||
{ "B" "F[-'(.8)!(.9)$CL]'!(.9)C" }
|
||||
{ "C" "F[+'(.8)!(.9)$BL]'!(.9)B" }
|
||||
|
||||
{ "L" "~c(8){+(30)f-(120)f-(120)f}" }
|
||||
}
|
||||
>>rules
|
||||
|
||||
dup axiom>> >>string ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -5,8 +5,8 @@ USING: accessors arrays assocs classes.tuple combinators
|
|||
compiler.units continuations debugger definitions help help.crossref
|
||||
help.markup help.topics io io.pathnames io.streams.string kernel lexer
|
||||
make math math.order memoize namespaces parser prettyprint sequences
|
||||
sets sorting source-files strings summary tools.vocabs vectors vocabs
|
||||
vocabs.parser words ;
|
||||
sets sorting source-files strings summary tools.crossref tools.vocabs
|
||||
vectors vocabs vocabs.parser words ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ GENERIC: fuel-pprint ( obj -- )
|
|||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
: fuel-maybe-scape ( ch -- seq )
|
||||
dup "?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ;
|
||||
|
||||
M: word fuel-pprint
|
||||
name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ;
|
||||
|
|
@ -151,7 +151,7 @@ SYMBOL: :uses
|
|||
: fuel-run-file ( path -- )
|
||||
[ fuel-set-use-hook run-file ] curry with-scope ; inline
|
||||
|
||||
: fuel-with-autouse ( quot -- )
|
||||
: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
|
||||
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
|
||||
|
||||
: (fuel-get-uses) ( lines -- )
|
||||
|
|
@ -184,13 +184,16 @@ SYMBOL: :uses
|
|||
[ [ first ] dip first <=> ] sort ; inline
|
||||
|
||||
: fuel-format-xrefs ( seq -- seq' )
|
||||
[ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ;
|
||||
[ word? ] filter [ fuel-word>xref ] map ; inline
|
||||
|
||||
: fuel-callers-xref ( word -- )
|
||||
usage fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-callees-xref ( word -- )
|
||||
uses fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
uses fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
: fuel-apropos-xref ( str -- )
|
||||
words-matching fuel-format-xrefs fuel-eval-set-result ; inline
|
||||
|
||||
! Completion support
|
||||
|
||||
|
|
@ -289,6 +292,23 @@ MEMO: fuel-find-word ( name -- word/f )
|
|||
fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if*
|
||||
fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-vocab-help) ( name -- element )
|
||||
\ article swap dup >vocab-link
|
||||
[
|
||||
[ summary [ , ] [ "No summary available" , ] if* ]
|
||||
[ drop \ $nl , ]
|
||||
[ vocab-help article [ content>> % ] when* ] tri
|
||||
] { } make 3array ;
|
||||
|
||||
: fuel-vocab-help ( name -- )
|
||||
(fuel-vocab-help) fuel-eval-set-result ; inline
|
||||
|
||||
: (fuel-index) ( seq -- seq )
|
||||
[ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ;
|
||||
|
||||
: fuel-index ( quot: ( -- seq ) -- )
|
||||
call (fuel-index) fuel-eval-set-result ; inline
|
||||
|
||||
! -run=fuel support
|
||||
|
||||
: fuel-startup ( -- ) "listener" run-file ; inline
|
||||
|
|
|
|||
|
|
@ -1,56 +1,54 @@
|
|||
FUEL, Factor's Ultimate Emacs Library
|
||||
FUEL, Factor's Ultimate Emacs Library -*- org -*-
|
||||
-------------------------------------
|
||||
|
||||
FUEL provides a complete environment for your Factor coding pleasure
|
||||
inside Emacs, including source code edition and interaction with a
|
||||
Factor listener instance running within Emacs.
|
||||
|
||||
FUEL was started by Jose A Ortega as an extension to Ed Cavazos'
|
||||
original factor.el code.
|
||||
FUEL was started by Jose A Ortega as an extension to Eduardo Cavazos'
|
||||
original factor.el code. Eduardo is also responsible of naming the
|
||||
beast.
|
||||
|
||||
Installation
|
||||
------------
|
||||
* Installation
|
||||
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
FUEL comes bundled with Factor's distribution. The folder misc/fuel
|
||||
contains Elisp code, and there's a fuel vocabulary in extras/fuel.
|
||||
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
To install FUEL, either add this line to your Emacs initialisation:
|
||||
|
||||
(load-file "<path/to/factor/installation>/misc/fuel/fu.el")
|
||||
|
||||
or
|
||||
or
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(require 'fuel)
|
||||
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
If all you want is a major mode for editing Factor code with pretty
|
||||
font colors and indentation, without running the factor listener
|
||||
inside Emacs, you can use instead:
|
||||
|
||||
(add-to-list load-path "<path/to/factor/installation>/fuel")
|
||||
(setq factor-mode-use-fuel nil)
|
||||
(require 'factor-mode)
|
||||
|
||||
Basic usage
|
||||
-----------
|
||||
* Basic usage
|
||||
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
If you're using the default factor binary and images locations inside
|
||||
the Factor's source tree, that should be enough to start using FUEL.
|
||||
Editing any file with the extension .factor will put you in
|
||||
factor-mode; try C-hm for a summary of available commands.
|
||||
|
||||
To start the listener, try M-x run-factor.
|
||||
To start the listener, try M-x run-factor.
|
||||
|
||||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
Many aspects of the environment can be customized:
|
||||
M-x customize-group fuel will show you how many.
|
||||
|
||||
Quick key reference
|
||||
-------------------
|
||||
* Quick key reference
|
||||
|
||||
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
|
||||
C-cC-eC-r is the same as C-cC-er)).
|
||||
(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
|
||||
C-cC-eC-r is the same as C-cC-er)).
|
||||
|
||||
* In factor source files:
|
||||
*** In factor source files:
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
|
@ -71,39 +69,46 @@ C-cC-eC-r is the same as C-cC-er)).
|
|||
- C-cC-dd : help for word at point
|
||||
- C-cC-ds : short help word at point
|
||||
- C-cC-de : show stack effect of current sexp (with prefix, region)
|
||||
- C-cC-dp : find words containing given substring (M-x fuel-apropos)
|
||||
|
||||
- C-cM-<, C-cC-d< : show callers of word at point
|
||||
- C-cM->, C-cC-d> : show callees of word at point
|
||||
|
||||
* In the listener:
|
||||
*** In the listener:
|
||||
|
||||
- TAB : complete word at point
|
||||
- M-. : edit word at point in Emacs
|
||||
- C-ca : toggle autodoc mode
|
||||
- C-cp : find words containing given substring (M-x fuel-apropos)
|
||||
- C-cs : toggle stack mode
|
||||
- C-cv : edit vocabulary
|
||||
- C-ch : help for word at point
|
||||
- C-ck : run file
|
||||
|
||||
* In the debugger (it pops up upon eval/compilation errors):
|
||||
*** In the debugger (it pops up upon eval/compilation errors):
|
||||
|
||||
- g : go to error
|
||||
- <digit> : invoke nth restart
|
||||
- w/e/l : invoke :warnings, :errors, :linkage
|
||||
- q : bury buffer
|
||||
|
||||
* In the Help browser:
|
||||
*** In the help browser:
|
||||
|
||||
- h : help for word at point
|
||||
- f/b : next/previous page
|
||||
- a : find words containing given substring (M-x fuel-apropos)
|
||||
- ba : bookmark current page
|
||||
- bb : display bookmarks
|
||||
- bd : delete bookmark at point
|
||||
- n/p : next/previous page
|
||||
- SPC/S-SPC : scroll up/down
|
||||
- TAB/S-TAB : next/previous link
|
||||
- r : refresh page
|
||||
- c : clean browsing history
|
||||
- M-. : edit word at point in Emacs
|
||||
- C-cz : switch to listener
|
||||
- q : bury buffer
|
||||
|
||||
* In crossref buffers
|
||||
*** In crossref buffers
|
||||
|
||||
- TAB/BACKTAB : navigate links
|
||||
- RET/mouse click : follow link
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
(require 'fuel-eval)
|
||||
(require 'fuel-markup)
|
||||
(require 'fuel-autodoc)
|
||||
(require 'fuel-xref)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-popup)
|
||||
|
|
@ -41,6 +42,11 @@
|
|||
:type 'integer
|
||||
:group 'fuel-help)
|
||||
|
||||
(defcustom fuel-help-bookmarks nil
|
||||
"Bookmars. Maintain this list using the help browser."
|
||||
:type 'list
|
||||
:group 'fuel-help)
|
||||
|
||||
|
||||
;;; Help browser history:
|
||||
|
||||
|
|
@ -49,13 +55,17 @@
|
|||
(make-ring fuel-help-history-cache-size) ; previous
|
||||
(make-ring fuel-help-history-cache-size))) ; next
|
||||
|
||||
(defvar fuel-help--history (fuel-help--make-history))
|
||||
(defsubst fuel-help--history-current ()
|
||||
(car fuel-help--history))
|
||||
|
||||
(defun fuel-help--history-push (term)
|
||||
(when (and (car fuel-help--history)
|
||||
(not (string= (caar fuel-help--history) (car term))))
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history term))
|
||||
(defun fuel-help--history-push (link)
|
||||
(unless (equal link (car fuel-help--history))
|
||||
(let ((next (fuel-help--history-next)))
|
||||
(unless (equal link next)
|
||||
(when next (fuel-help--history-previous))
|
||||
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history))
|
||||
(setcar fuel-help--history link))))
|
||||
link)
|
||||
|
||||
(defun fuel-help--history-next ()
|
||||
(when (not (ring-empty-p (nth 2 fuel-help--history)))
|
||||
|
|
@ -69,6 +79,25 @@
|
|||
(ring-insert (nth 2 fuel-help--history) (car fuel-help--history)))
|
||||
(setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0))))
|
||||
|
||||
(defvar fuel-help--history (fuel-help--make-history))
|
||||
|
||||
|
||||
;;; Page cache:
|
||||
|
||||
(defun fuel-help--history-current-content ()
|
||||
(fuel-help--cache-get (car fuel-help--history)))
|
||||
|
||||
(defvar fuel-help--cache (make-hash-table :weakness 'key :test 'equal))
|
||||
|
||||
(defsubst fuel-help--cache-get (name)
|
||||
(gethash name fuel-help--cache))
|
||||
|
||||
(defsubst fuel-help--cache-insert (name str)
|
||||
(puthash name str fuel-help--cache))
|
||||
|
||||
(defsubst fuel-help--cache-clear ()
|
||||
(clrhash fuel-help--cache))
|
||||
|
||||
|
||||
;;; Fuel help buffer and internals:
|
||||
|
||||
|
|
@ -78,6 +107,9 @@
|
|||
|
||||
(defvar fuel-help--prompt-history nil)
|
||||
|
||||
(make-local-variable
|
||||
(defvar fuel-help--buffer-link nil))
|
||||
|
||||
(defun fuel-help--read-word (see)
|
||||
(let* ((def (fuel-syntax-symbol-at-point))
|
||||
(prompt (format "See%s help on%s: " (if see " short" "")
|
||||
|
|
@ -101,39 +133,90 @@
|
|||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(message "No help for '%s'" def)
|
||||
(fuel-help--insert-contents def res)))))))
|
||||
(fuel-help--insert-contents (list def def 'word) res)))))))
|
||||
|
||||
(defun fuel-help--get-article (name label)
|
||||
(message "Retriving article ...")
|
||||
(message "Retrieving article ...")
|
||||
(let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t))
|
||||
(ret (fuel-eval--send/wait cmd 2000))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(fuel-help--insert-contents label res)
|
||||
(message "")))
|
||||
(if (not res)
|
||||
(message "Article '%s' not found" label)
|
||||
(fuel-help--insert-contents (list name label 'article) res)
|
||||
(message ""))))
|
||||
|
||||
(defun fuel-help--follow-link (label link type)
|
||||
(defun fuel-help--get-vocab (name)
|
||||
(message "Retrieving vocabulary help ...")
|
||||
(let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name)))
|
||||
(ret (fuel-eval--send/wait cmd 2000))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(if (not res)
|
||||
(message "No help available for vocabulary '%s'" name)
|
||||
(fuel-help--insert-contents (list name name 'vocab) res)
|
||||
(message ""))))
|
||||
|
||||
(defun fuel-help--follow-link (link label type &optional no-cache)
|
||||
(let* ((llink (list link label type))
|
||||
(cached (and (not no-cache) (fuel-help--cache-get llink))))
|
||||
(if (not cached)
|
||||
(let ((fuel-help-always-ask nil))
|
||||
(cond ((eq type 'word) (fuel-help--word-help nil link))
|
||||
((eq type 'article) (fuel-help--get-article link label))
|
||||
(t (message (format "Links of type %s not yet implemented" type))))))
|
||||
((eq type 'vocab) (fuel-help--get-vocab link))
|
||||
((eq type 'bookmarks) (fuel-help-display-bookmarks))
|
||||
(t (error "Links of type %s not yet implemented" type))))
|
||||
(fuel-help--insert-contents llink cached))))
|
||||
|
||||
(defun fuel-help--insert-contents (def art &optional nopush)
|
||||
(defun fuel-help--insert-contents (key content)
|
||||
(let ((hb (fuel-help--buffer))
|
||||
(inhibit-read-only t)
|
||||
(font-lock-verbose nil))
|
||||
(set-buffer hb)
|
||||
(erase-buffer)
|
||||
(if (stringp art)
|
||||
(insert art)
|
||||
(fuel-markup--print art)
|
||||
(fuel-markup--insert-newline))
|
||||
(unless nopush
|
||||
(fuel-help--history-push (cons def (buffer-string))))
|
||||
(if (stringp content)
|
||||
(insert content)
|
||||
(fuel-markup--print content)
|
||||
(fuel-markup--insert-newline)
|
||||
(fuel-help--cache-insert key (buffer-string)))
|
||||
(fuel-help--history-push key)
|
||||
(setq fuel-help--buffer-link key)
|
||||
(set-buffer-modified-p nil)
|
||||
(fuel-popup--display)
|
||||
(goto-char (point-min))
|
||||
(message "")))
|
||||
|
||||
|
||||
;;; Bookmarks:
|
||||
|
||||
(defun fuel-help-bookmark-page ()
|
||||
"Add current help page to bookmarks."
|
||||
(interactive)
|
||||
(let ((link fuel-help--buffer-link))
|
||||
(unless link (error "No link associated to this page"))
|
||||
(add-to-list 'fuel-help-bookmarks link)
|
||||
(customize-save-variable 'fuel-help-bookmarks fuel-help-bookmarks)
|
||||
(message "Bookmark '%s' saved" (cadr link))))
|
||||
|
||||
(defun fuel-help-delete-bookmark ()
|
||||
"Delete link at point from bookmarks."
|
||||
(interactive)
|
||||
(let ((link (fuel-markup--link-at-point)))
|
||||
(unless link (error "No link at point"))
|
||||
(unless (member link fuel-help-bookmarks)
|
||||
(error "'%s' is not bookmarked" (cadr link)))
|
||||
(customize-save-variable 'fuel-help-bookmarks
|
||||
(remove link fuel-help-bookmarks))
|
||||
(message "Bookmark '%s' delete" (cadr link))
|
||||
(fuel-help-display-bookmarks)))
|
||||
|
||||
(defun fuel-help-display-bookmarks ()
|
||||
"Display bookmarked pages."
|
||||
(interactive)
|
||||
(let ((links (mapcar (lambda (l) (cons '$subsection l)) fuel-help-bookmarks)))
|
||||
(unless links (error "No links to display"))
|
||||
(fuel-help--insert-contents '("bookmarks" "Bookmars" bookmarks)
|
||||
`(article "Bookmarks" ,links))))
|
||||
|
||||
|
||||
;;; Interactive help commands:
|
||||
|
||||
|
|
@ -151,26 +234,30 @@ buffer."
|
|||
(defun fuel-help-next ()
|
||||
"Go to next page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-next))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No next page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
(let ((item (fuel-help--history-next)))
|
||||
(unless item (error "No next page"))
|
||||
(apply 'fuel-help--follow-link item)))
|
||||
|
||||
(defun fuel-help-previous ()
|
||||
"Go to next page in help browser."
|
||||
"Go to previous page in help browser."
|
||||
(interactive)
|
||||
(let ((item (fuel-help--history-previous))
|
||||
(fuel-help-always-ask nil))
|
||||
(unless item
|
||||
(error "No previous page"))
|
||||
(fuel-help--insert-contents (car item) (cdr item) t)))
|
||||
(let ((item (fuel-help--history-previous)))
|
||||
(unless item (error "No previous page"))
|
||||
(apply 'fuel-help--follow-link item)))
|
||||
|
||||
(defun fuel-help-refresh ()
|
||||
"Refresh the contents of current page."
|
||||
(interactive)
|
||||
(when fuel-help--buffer-link
|
||||
(apply 'fuel-help--follow-link (append fuel-help--buffer-link '(t)))))
|
||||
|
||||
(defun fuel-help-clean-history ()
|
||||
"Clean up the help browser cache of visited pages."
|
||||
(interactive)
|
||||
(when (y-or-n-p "Clean browsing history? ")
|
||||
(setq fuel-help--history (fuel-help--make-history)))
|
||||
(fuel-help--cache-clear)
|
||||
(setq fuel-help--history (fuel-help--make-history))
|
||||
(fuel-help-refresh))
|
||||
(message ""))
|
||||
|
||||
|
||||
|
|
@ -180,13 +267,15 @@ buffer."
|
|||
(let ((map (make-sparse-keymap)))
|
||||
(suppress-keymap map)
|
||||
(set-keymap-parent map button-buffer-map)
|
||||
(define-key map "b" 'fuel-help-previous)
|
||||
(define-key map "a" 'fuel-apropos)
|
||||
(define-key map "ba" 'fuel-help-bookmark-page)
|
||||
(define-key map "bb" 'fuel-help-display-bookmarks)
|
||||
(define-key map "bd" 'fuel-help-delete-bookmark)
|
||||
(define-key map "c" 'fuel-help-clean-history)
|
||||
(define-key map "f" 'fuel-help-next)
|
||||
(define-key map "h" 'fuel-help)
|
||||
(define-key map "l" 'fuel-help-previous)
|
||||
(define-key map "p" 'fuel-help-previous)
|
||||
(define-key map "n" 'fuel-help-next)
|
||||
(define-key map "p" 'fuel-help-previous)
|
||||
(define-key map "r" 'fuel-help-refresh)
|
||||
(define-key map (kbd "SPC") 'scroll-up)
|
||||
(define-key map (kbd "S-SPC") 'scroll-down)
|
||||
(define-key map "\M-." 'fuel-edit-word-at-point)
|
||||
|
|
@ -207,12 +296,7 @@ buffer."
|
|||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(setq mode-name "FUEL Help")
|
||||
(setq major-mode 'fuel-help-mode)
|
||||
|
||||
(setq fuel-markup--follow-link-function 'fuel-help--follow-link)
|
||||
|
||||
(setq fuel-autodoc-mode-string "")
|
||||
(fuel-autodoc-mode)
|
||||
|
||||
(setq buffer-read-only t))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-listener.el --- starting the fuel listener
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
(require 'fuel-stack)
|
||||
(require 'fuel-completion)
|
||||
(require 'fuel-xref)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-connection)
|
||||
(require 'fuel-syntax)
|
||||
|
|
@ -169,6 +170,7 @@ buffer."
|
|||
(define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
|
||||
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
|
||||
(define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode)
|
||||
(define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos)
|
||||
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
|
||||
(define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary)
|
||||
(define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary)
|
||||
|
|
|
|||
|
|
@ -52,29 +52,41 @@
|
|||
(defun fuel-markup--follow-link (button)
|
||||
(when fuel-markup--follow-link-function
|
||||
(funcall fuel-markup--follow-link-function
|
||||
(button-label button)
|
||||
(button-get button 'markup-link)
|
||||
(button-get button 'markup-label)
|
||||
(button-get button 'markup-link-type))))
|
||||
|
||||
(defun fuel-markup--echo-link (label link type)
|
||||
(defun fuel-markup--echo-link (link label type)
|
||||
(message "Link %s pointing to %s named %s" label type link))
|
||||
|
||||
(defun fuel-markup--insert-button (label link type)
|
||||
(insert-text-button (format "%s" label)
|
||||
(let ((label (format "%s" label))
|
||||
(link (format "%s" link)))
|
||||
(insert-text-button label
|
||||
:type 'fuel-markup--button
|
||||
'markup-link (format "%s" link)
|
||||
'markup-link-type type))
|
||||
'markup-link link
|
||||
'markup-label label
|
||||
'markup-link-type type
|
||||
'help-echo (format "%s (%s)" label type))))
|
||||
|
||||
(defun fuel-markup--article-title (name)
|
||||
(fuel-eval--retort-result
|
||||
(fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel"))))
|
||||
|
||||
(defun fuel-markup--link-at-point ()
|
||||
(let ((button (condition-case nil (forward-button 0) (error nil))))
|
||||
(when button
|
||||
(list (button-get button 'markup-link)
|
||||
(button-get button 'markup-label)
|
||||
(button-get button 'markup-link-type)))))
|
||||
|
||||
|
||||
;;; Markup printers:
|
||||
|
||||
(defconst fuel-markup--printers
|
||||
'(($class-description . fuel-markup--class-description)
|
||||
($code . fuel-markup--code)
|
||||
($command . fuel-markup--command)
|
||||
($contract . fuel-markup--contract)
|
||||
($curious . fuel-markup--curious)
|
||||
($definition . fuel-markup--definition)
|
||||
|
|
@ -86,6 +98,7 @@
|
|||
($example . fuel-markup--example)
|
||||
($examples . fuel-markup--examples)
|
||||
($heading . fuel-markup--heading)
|
||||
($index . fuel-markup--index)
|
||||
($instance . fuel-markup--instance)
|
||||
($io-error . fuel-markup--io-error)
|
||||
($link . fuel-markup--link)
|
||||
|
|
@ -98,6 +111,7 @@
|
|||
($nl . fuel-markup--newline)
|
||||
($notes . fuel-markup--notes)
|
||||
($parsing-note . fuel-markup--parsing-note)
|
||||
($predicate . fuel-markup--predicate)
|
||||
($prettyprinting-note . fuel-markup--prettyprinting-note)
|
||||
($quotation . fuel-markup--quotation)
|
||||
($references . fuel-markup--references)
|
||||
|
|
@ -142,6 +156,11 @@
|
|||
((symbolp e) (fuel-markup--print (list '$link e)))
|
||||
(t (insert (format "\n%S\n" e)))))
|
||||
|
||||
(defun fuel-markup--print-str (e)
|
||||
(with-temp-buffer
|
||||
(fuel-markup--print e)
|
||||
(buffer-string)))
|
||||
|
||||
(defun fuel-markup--maybe-nl ()
|
||||
(setq fuel-markup--maybe-nl (point)))
|
||||
|
||||
|
|
@ -190,6 +209,12 @@
|
|||
(fuel-markup--link (cons '$link (cdr e)))
|
||||
(fuel-markup--maybe-nl))
|
||||
|
||||
(defun fuel-markup--vocab-subsection (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
(insert " - ")
|
||||
(fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
|
||||
(fuel-markup--maybe-nl))
|
||||
|
||||
(defun fuel-markup--newline (e)
|
||||
(fuel-markup--insert-newline)
|
||||
(newline))
|
||||
|
|
@ -214,10 +239,8 @@
|
|||
(insert (cadr e))))
|
||||
|
||||
(defun fuel-markup--snippet (e)
|
||||
(let ((snip (cadr e)))
|
||||
(if (stringp snip)
|
||||
(insert (fuel-font-lock--factor-str snip))
|
||||
(fuel-markup--print snip))))
|
||||
(let ((snip (format "%s" (cdr e))))
|
||||
(insert (fuel-font-lock--factor-str snip))))
|
||||
|
||||
(defun fuel-markup--code (e)
|
||||
(fuel-markup--insert-nl-if-nb)
|
||||
|
|
@ -229,6 +252,9 @@
|
|||
(newline))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--command (e)
|
||||
(fuel-markup--snippet (list '$snippet (nth 3 e))))
|
||||
|
||||
(defun fuel-markup--syntax (e)
|
||||
(fuel-markup--insert-heading "Syntax")
|
||||
(fuel-markup--print (cons '$code (cdr e)))
|
||||
|
|
@ -236,30 +262,46 @@
|
|||
|
||||
(defun fuel-markup--examples (e)
|
||||
(fuel-markup--insert-heading "Examples")
|
||||
(fuel-markup--print (cdr e)))
|
||||
(dolist (ex (cdr e))
|
||||
(fuel-markup--print ex)
|
||||
(newline)))
|
||||
|
||||
(defun fuel-markup--example (e)
|
||||
(fuel-markup--print (cons '$code (cdr e))))
|
||||
(fuel-markup--snippet (list '$snippet (cadr e))))
|
||||
|
||||
(defun fuel-markup--markup-example (e)
|
||||
(fuel-markup--print (cons '$code (cdr e))))
|
||||
(fuel-markup--snippet (cons '$snippet (cadr e))))
|
||||
|
||||
(defun fuel-markup--link (e)
|
||||
(let* ((link (cadr e))
|
||||
(type (if (symbolp link) 'word 'article))
|
||||
(label (or (and (eq type 'article)
|
||||
(let* ((link (nth 1 e))
|
||||
(type (or (nth 3 e) (if (symbolp link) 'word 'article)))
|
||||
(label (or (nth 2 e)
|
||||
(and (eq type 'article)
|
||||
(fuel-markup--article-title link))
|
||||
link)))
|
||||
(fuel-markup--insert-button label link type)))
|
||||
|
||||
(defun fuel-markup--links (e)
|
||||
(dolist (link (cdr e))
|
||||
(insert " ")
|
||||
(fuel-markup--link (list '$link link))
|
||||
(insert " ")))
|
||||
(insert ", "))
|
||||
(delete-backward-char 2))
|
||||
|
||||
(defun fuel-markup--vocab-subsection (e)
|
||||
(insert (format " %S " e)))
|
||||
(defun fuel-markup--index-quotation (q)
|
||||
(cond ((null q) null)
|
||||
((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q)))
|
||||
(t q)))
|
||||
|
||||
(defun fuel-markup--index (e)
|
||||
(let* ((q (fuel-markup--index-quotation (cadr e)))
|
||||
(cmd `(:fuel* ((,q fuel-index)) "fuel"
|
||||
("builtins" "help" "help.topics" "classes"
|
||||
"classes.builtin" "classes.tuple"
|
||||
"classes.singleton" "classes.union"
|
||||
"classes.intersection" "classes.predicate")))
|
||||
(subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200))))
|
||||
(when subs
|
||||
(fuel-markup--print subs))))
|
||||
|
||||
(defun fuel-markup--vocab-link (e)
|
||||
(fuel-markup--insert-button (cadr e) (cadr e) 'vocab))
|
||||
|
|
@ -271,8 +313,8 @@
|
|||
(insert " ")))
|
||||
|
||||
(defun fuel-markup--vocabulary (e)
|
||||
(fuel-markup--insert-heading "Vocabulary:" t)
|
||||
(insert " " (cadr e))
|
||||
(fuel-markup--insert-heading "Vocabulary: " t)
|
||||
(fuel-markup--vocab-link (cons '$vocab-link (cdr e)))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--list (e)
|
||||
|
|
@ -314,6 +356,13 @@
|
|||
(fuel-markup--print (cdr val))
|
||||
(newline)))
|
||||
|
||||
(defun fuel-markup--predicate (e)
|
||||
(fuel-markup--values '($values ("object" object) ("?" "a boolean")))
|
||||
(let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1))))
|
||||
(fuel-markup--description
|
||||
`($description "Tests if the object is an instance of the "
|
||||
($link ,word) " class."))))
|
||||
|
||||
(defun fuel-markup--side-effects (e)
|
||||
(fuel-markup--insert-heading "Side effects")
|
||||
(insert "Modifies ")
|
||||
|
|
@ -343,12 +392,19 @@
|
|||
|
||||
(defun fuel-markup--references (e)
|
||||
(fuel-markup--insert-heading "References")
|
||||
(fuel-markup--links (cons '$links (cdr e))))
|
||||
(dolist (ref (cdr e))
|
||||
(if (listp ref)
|
||||
(fuel-markup--print ref)
|
||||
(fuel-markup--subsection (list '$subsection ref)))))
|
||||
|
||||
(defun fuel-markup--see-also (e)
|
||||
(fuel-markup--insert-heading "See also")
|
||||
(fuel-markup--links (cons '$links (cdr e))))
|
||||
|
||||
(defun fuel-markup--related (e)
|
||||
(fuel-markup--insert-heading "See also")
|
||||
(fuel-markup--links (cons '$links (cadr e))))
|
||||
|
||||
(defun fuel-markup--shuffle (e)
|
||||
(insert "\nShuffle word. Re-arranges the stack "
|
||||
"according to the stack effect pattern.")
|
||||
|
|
@ -376,6 +432,12 @@
|
|||
(fuel-markup--print (cdr elem))
|
||||
(fuel-markup--insert-newline))
|
||||
|
||||
(defun fuel-markup--quotation (e)
|
||||
(insert "a ")
|
||||
(fuel-markup--link (list '$link 'quotation 'quotation 'word))
|
||||
(insert " with stack effect ")
|
||||
(fuel-markup--snippet (list '$snippet (nth 1 e))))
|
||||
|
||||
(defun fuel-markup--warning (e)
|
||||
(fuel-markup--elem-with-heading e "Warning"))
|
||||
|
||||
|
|
@ -394,9 +456,6 @@
|
|||
(defun fuel-markup--contract (e)
|
||||
(fuel-markup--elem-with-heading e "Generic word contract"))
|
||||
|
||||
(defun fuel-markup--related (e)
|
||||
(fuel-markup--elem-with-heading e "See also"))
|
||||
|
||||
(defun fuel-markup--errors (e)
|
||||
(fuel-markup--elem-with-heading e "Errors"))
|
||||
|
||||
|
|
@ -404,14 +463,17 @@
|
|||
(fuel-markup--elem-with-heading e "Notes"))
|
||||
|
||||
(defun fuel-markup--see (e)
|
||||
(insert (format " %S " e)))
|
||||
(let* ((word (nth 1 e))
|
||||
(cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t)))
|
||||
(res (and cmd
|
||||
(fuel-eval--retort-result (fuel-eval--send/wait cmd 100)))))
|
||||
(if res
|
||||
(fuel-markup--code (list '$code res))
|
||||
(fuel-markup--snippet (list '$snippet word)))))
|
||||
|
||||
(defun fuel-markup--synopsis (e)
|
||||
(insert (format " %S " e)))
|
||||
|
||||
(defun fuel-markup--quotation (e)
|
||||
(insert (format " %S " e)))
|
||||
|
||||
|
||||
(provide 'fuel-markup)
|
||||
;;; fuel-markup.el ends here
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; fuel-mode.el -- Minor mode enabling FUEL niceties
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
|
|
@ -224,6 +224,11 @@ With prefix argument, ask for word."
|
|||
(message "Looking up %s's callees ..." word)
|
||||
(fuel-xref--show-callees word))))
|
||||
|
||||
(defun fuel-apropos (str)
|
||||
"Show a list of words containing the given substring."
|
||||
(interactive "MFind words containing: ")
|
||||
(message "Looking up %s's references ..." str)
|
||||
(fuel-xref--apropos str))
|
||||
|
||||
;;; Minor mode definition:
|
||||
|
||||
|
|
@ -289,6 +294,7 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key ?d ?> 'fuel-show-callees)
|
||||
(fuel-mode--key ?d ?< 'fuel-show-callers)
|
||||
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
|
||||
(fuel-mode--key ?d ?p 'fuel-apropos)
|
||||
(fuel-mode--key ?d ?d 'fuel-help)
|
||||
(fuel-mode--key ?d ?e 'fuel-stack-effect-sexp)
|
||||
(fuel-mode--key ?d ?s 'fuel-help-short)
|
||||
|
|
|
|||
|
|
@ -75,11 +75,10 @@ cursor at the first ocurrence of the used word."
|
|||
(defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)")
|
||||
|
||||
(defun fuel-xref--title (word cc count)
|
||||
(let ((cc (if cc "using" "used by")))
|
||||
(put-text-property 0 (length word) 'font-lock-face 'bold word)
|
||||
(cond ((zerop count) (format "No known words %s %s" cc word))
|
||||
((= 1 count) (format "1 word %s %s:" cc word))
|
||||
(t (format "%s words %s %s:" count cc word)))))
|
||||
(t (format "%s words %s %s:" count cc word))))
|
||||
|
||||
(defun fuel-xref--insert-ref (ref)
|
||||
(when (and (stringp (first ref))
|
||||
|
|
@ -124,12 +123,17 @@ cursor at the first ocurrence of the used word."
|
|||
(defun fuel-xref--show-callers (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display word t res)))
|
||||
(fuel-xref--fill-and-display word "using" res)))
|
||||
|
||||
(defun fuel-xref--show-callees (word)
|
||||
(let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display word nil res)))
|
||||
(fuel-xref--fill-and-display word "used by" res)))
|
||||
|
||||
(defun fuel-xref--apropos (str)
|
||||
(let* ((cmd `(:fuel* ((,str fuel-apropos-xref))))
|
||||
(res (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
|
||||
(fuel-xref--fill-and-display str "containing" res)))
|
||||
|
||||
|
||||
;;; Xref mode:
|
||||
|
|
|
|||
Loading…
Reference in New Issue