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

db4
Slava Pestov 2008-08-30 17:15:02 -05:00
commit c0211437e8
73 changed files with 382 additions and 300 deletions

View File

@ -6,8 +6,10 @@ HELP: ALIAS:
{ $values { "new-word" word } { "existing-word" word } } { $values { "new-word" word } { "existing-word" word } }
{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." } { $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
{ $examples { $examples
{ $example "ALIAS: sequence-nth nth" { $example "USING: alias prettyprint sequences ;"
"0 { 10 20 30 } sequence-nth" "IN: alias.test"
"ALIAS: sequence-nth nth"
"0 { 10 20 30 } sequence-nth ."
"10" "10"
} }
} ; } ;

1
basis/alias/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -1,13 +1,13 @@
IN: alien.structs IN: alien.structs
USING: alien.c-types strings help.markup help.syntax USING: alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays slots.deprecated alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces ; kernel words slots assocs namespaces accessors ;
! Deprecated code ! Deprecated code
: ($spec-reader-values) ( slot-spec class -- element ) : ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array dup ?word-name swap 2array
over slot-spec-name over name>>
rot slot-spec-class 2array 2array rot class>> 2array 2array
[ { $instance } swap suffix ] assoc-map ; [ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- ) : $spec-reader-values ( slot-spec class -- )
@ -16,14 +16,14 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- ) : $spec-reader-description ( slot-spec class -- )
[ [
"Outputs the value stored in the " , "Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name suffix , { $snippet } rot name>> suffix ,
" slot of " , " slot of " ,
{ $instance } swap suffix , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;
: slot-of-reader ( reader specs -- spec/f ) : slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ; [ reader>> eq? ] with find nip ;
: $spec-reader ( reader slot-specs class -- ) : $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r> >r slot-of-reader r>
@ -46,14 +46,14 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- ) : $spec-writer-description ( slot-spec class -- )
[ [
"Stores a new value to the " , "Stores a new value to the " ,
{ $snippet } rot slot-spec-name suffix , { $snippet } rot name>> suffix ,
" slot of " , " slot of " ,
{ $instance } swap suffix , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;
: slot-of-writer ( writer specs -- spec/f ) : slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ; [ writer>> eq? ] with find nip ;
: $spec-writer ( writer slot-specs class -- ) : $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r> >r slot-of-writer r>

View File

@ -11,17 +11,17 @@ IN: alien.structs
: struct-offsets ( specs -- size ) : struct-offsets ( specs -- size )
0 [ 0 [
[ class>> align-offset ] keep [ class>> align-offset ] keep
[ set-slot-spec-offset ] 2keep [ (>>offset) ] 2keep
class>> heap-size + class>> heap-size +
] reduce ; ] reduce ;
: define-struct-slot-word ( spec word quot -- ) : define-struct-slot-word ( spec word quot -- )
rot slot-spec-offset prefix define-inline ; rot offset>> prefix define-inline ;
: define-getter ( type spec -- ) : define-getter ( type spec -- )
[ set-reader-props ] keep [ set-reader-props ] keep
[ ] [ ]
[ slot-spec-reader ] [ reader>> ]
[ [
class>> class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append [ c-getter ] [ c-type c-type-boxer-quot ] bi append
@ -31,7 +31,7 @@ IN: alien.structs
: define-setter ( type spec -- ) : define-setter ( type spec -- )
[ set-writer-props ] keep [ set-writer-props ] keep
[ ] [ ]
[ slot-spec-writer ] [ writer>> ]
[ class>> c-setter ] tri [ class>> c-setter ] tri
define-struct-slot-word ; define-struct-slot-word ;

View File

@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ;
[ (ymdhms>timestamp) ] with-string-reader ; [ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp ) : (hms>timestamp) ( -- timestamp )
f f f read-hms instant <timestamp> ; 0 0 0 read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp ) : hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ; [ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp ) : (ymd>timestamp) ( -- timestamp )
read-ymd f f f instant <timestamp> ; read-ymd 0 0 0 instant <timestamp> ;
: ymd>timestamp ( str -- timestamp ) : ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ; [ (ymd>timestamp) ] with-string-reader ;

View File

@ -1,7 +1,7 @@
IN: concurrency.locks.tests IN: concurrency.locks.tests
USING: tools.test concurrency.locks concurrency.count-downs USING: tools.test concurrency.locks concurrency.count-downs
concurrency.messaging concurrency.mailboxes locals kernel concurrency.messaging concurrency.mailboxes locals kernel
threads sequences calendar ; threads sequences calendar accessors ;
:: lock-test-0 ( -- ) :: lock-test-0 ( -- )
[let | v [ V{ } clone ] [let | v [ V{ } clone ]
@ -174,7 +174,7 @@ threads sequences calendar ;
] ; ] ;
[ lock-timeout-test ] [ [ lock-timeout-test ] [
linked-error-thread thread-name "Lock timeout-er" = linked-error-thread name>> "Lock timeout-er" =
] must-fail-with ] must-fail-with
:: read/write-test ( -- ) :: read/write-test ( -- )

View File

@ -10,8 +10,8 @@ IN: concurrency.messaging
GENERIC: send ( message thread -- ) GENERIC: send ( message thread -- )
: mailbox-of ( thread -- mailbox ) : mailbox-of ( thread -- mailbox )
dup thread-mailbox [ ] [ dup mailbox>> [ ] [
<mailbox> dup rot set-thread-mailbox <mailbox> [ >>mailbox drop ] keep
] ?if ; ] ?if ;
M: thread send ( message thread -- ) M: thread send ( message thread -- )

View File

@ -58,8 +58,7 @@ INSTANCE: float-array sequence
: 4float-array ( w x y z -- array ) : 4float-array ( w x y z -- array )
T{ float-array } 4sequence ; inline T{ float-array } 4sequence ; inline
: F{ ( parsed -- parsed ) : F{ \ } [ >float-array ] parse-literal ; parsing
\ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ; M: float-array pprint-delims drop \ F{ \ } ;

View File

@ -41,7 +41,7 @@ ready ;
SYMBOL: remote-address SYMBOL: remote-address
GENERIC: handle-client* ( server -- ) GENERIC: handle-client* ( threaded-server -- )
<PRIVATE <PRIVATE
@ -75,13 +75,13 @@ M: threaded-server handle-client* handler>> call ;
: thread-name ( server-name addrspec -- string ) : thread-name ( server-name addrspec -- string )
unparse " connection from " swap 3append ; unparse " connection from " swap 3append ;
: accept-connection ( server -- ) : accept-connection ( threaded-server -- )
[ accept ] [ addr>> ] bi [ accept ] [ addr>> ] bi
[ '[ , , , handle-client ] ] [ '[ , , , handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi [ drop threaded-server get name>> swap thread-name ] 2bi
spawn drop ; spawn drop ;
: accept-loop ( server -- ) : accept-loop ( threaded-server -- )
[ [
threaded-server get semaphore>> threaded-server get semaphore>>
[ [ accept-connection ] with-semaphore ] [ [ accept-connection ] with-semaphore ]
@ -89,7 +89,7 @@ M: threaded-server handle-client* handler>> call ;
if* if*
] [ accept-loop ] bi ; inline recursive ] [ accept-loop ] bi ; inline recursive
: started-accept-loop ( server -- ) : started-accept-loop ( threaded-server -- )
threaded-server get threaded-server get
[ sockets>> push ] [ ready>> raise-flag ] bi ; [ sockets>> push ] [ ready>> raise-flag ] bi ;

View File

@ -62,7 +62,7 @@ ARTICLE: "network-streams" "Networking"
ABOUT: "network-streams" ABOUT: "network-streams"
HELP: local HELP: local
{ $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $link local-path } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." } { $class-description "Local address specifier for Unix domain sockets on Unix systems. The " { $snippet "path" } " slot holds the path name of the socket. New instances are created by calling " { $link <local> } "." }
{ $examples { $examples
{ $code "\"/tmp/.X11-unix/0\" <local>" } { $code "\"/tmp/.X11-unix/0\" <local>" }
} ; } ;

View File

@ -38,7 +38,7 @@ HELP: pheap>alist
{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ; { $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
HELP: pheap>values HELP: pheap>values
{ $values { "heap" "a persistent heap" } { "values" array } } { $values { "heap" "a persistent heap" } { "seq" array } }
{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ; { $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
ARTICLE: "persistent-heaps" "Persistent heaps" ARTICLE: "persistent-heaps" "Persistent heaps"

View File

@ -38,7 +38,7 @@ ARTICLE: "thread-state" "Thread-local state and variables"
{ $subsection tchange } { $subsection tchange }
"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set." "Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
$nl $nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":" "Global hashtable of all threads, keyed by " { $snippet "id" } ":"
{ $subsection threads } { $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ; "Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
@ -63,10 +63,10 @@ ABOUT: "threads"
HELP: thread HELP: thread
{ $class-description "A thread. The slots are as follows:" { $class-description "A thread. The slots are as follows:"
{ $list { $list
{ { $link thread-id } " - a unique identifier assigned to each thread." } { { $snippet "id" } " - a unique identifier assigned to each thread." }
{ { $link thread-name } " - the name passed to " { $link spawn } "." } { { $snippet "name" } " - the name passed to " { $link spawn } "." }
{ { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." } { { $snippet "quot" } " - the initial quotation passed to " { $link spawn } "." }
{ { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." } { { $snippet "continuation" } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
} }
} ; } ;

View File

@ -6,14 +6,14 @@ heaps.private system math math.parser math.order accessors ;
IN: tools.threads IN: tools.threads
: thread. ( thread -- ) : thread. ( thread -- )
dup thread-id pprint-cell dup id>> pprint-cell
dup thread-name over [ write-object ] with-cell dup name>> over [ write-object ] with-cell
dup thread-state [ dup state>> [
[ dup self eq? "running" "yield" ? ] unless* [ dup self eq? "running" "yield" ? ] unless*
write write
] with-cell ] with-cell
[ [
thread-sleep-entry [ sleep-entry>> [
key>> millis [-] number>string write key>> millis [-] number>string write
" ms" write " ms" write
] when* ] when*

View File

@ -4,7 +4,7 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces math.parser arrays vocabs.loader vocabs sequences namespaces math.parser arrays
hashtables assocs memoize summary sorting splitting combinators hashtables assocs memoize summary sorting splitting combinators
source-files debugger continuations compiler.errors init source-files debugger continuations compiler.errors init
checksums checksums.crc32 sets ; checksums checksums.crc32 sets accessors ;
IN: tools.vocabs IN: tools.vocabs
: vocab-tests-file ( vocab -- path ) : vocab-tests-file ( vocab -- path )
@ -61,10 +61,10 @@ SYMBOL: failures
: source-modified? ( path -- ? ) : source-modified? ( path -- ? )
dup source-files get at [ dup source-files get at [
dup source-file-path dup path>>
dup exists? [ dup exists? [
utf8 file-lines crc32 checksum-lines utf8 file-lines crc32 checksum-lines
swap source-file-checksum = not swap checksum>> = not
] [ ] [
2drop f 2drop f
] if ] if
@ -175,7 +175,7 @@ M: vocab summary
[ [
dup vocab-summary % dup vocab-summary %
" (" % " (" %
vocab-words assoc-size # words>> assoc-size #
" words)" % " words)" %
] "" make ; ] "" make ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises models tools.walker kernel USING: concurrency.promises models tools.walker kernel
sequences concurrency.messaging locals continuations sequences concurrency.messaging locals continuations
threads namespaces namespaces.private assocs ; threads namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug IN: tools.walker.debug
:: test-walker ( quot -- data ) :: test-walker ( quot -- data )
@ -26,6 +26,6 @@ IN: tools.walker.debug
send-synchronous drop send-synchronous drop
p ?promise p ?promise
thread-variables walker-continuation swap at variables>> walker-continuation swap at
model-value continuation-data model-value data>>
] ; ] ;

View File

@ -22,8 +22,8 @@ DEFER: start-walker-thread
: get-walker-thread ( -- status continuation thread ) : get-walker-thread ( -- status continuation thread )
walker-thread tget [ walker-thread tget [
[ thread-variables walker-status swap at ] [ variables>> walker-status swap at ]
[ thread-variables walker-continuation swap at ] [ variables>> walker-continuation swap at ]
[ ] tri [ ] tri
] [ ] [
f <model> f <model>
@ -43,7 +43,7 @@ DEFER: start-walker-thread
} cond ; } cond ;
: break ( -- ) : break ( -- )
continuation callstack over set-continuation-call continuation callstack >>call
show-walker send-synchronous show-walker send-synchronous
after-break ; after-break ;
@ -248,7 +248,7 @@ SYMBOL: +stopped+
: associate-thread ( walker -- ) : associate-thread ( walker -- )
walker-thread tset walker-thread tset
[ f walker-thread tget send-synchronous drop ] [ f walker-thread tget send-synchronous drop ]
self set-thread-exit-handler ; self (>>exit-handler) ;
: start-walker-thread ( status continuation -- thread' ) : start-walker-thread ( status continuation -- thread' )
self [ self [
@ -258,7 +258,7 @@ SYMBOL: +stopped+
V{ } clone walker-history tset V{ } clone walker-history tset
walker-loop walker-loop
] 3curry ] 3curry
"Walker on " self thread-name append spawn "Walker on " self name>> append spawn
[ associate-thread ] keep ; [ associate-thread ] keep ;
! For convenience ! For convenience

View File

@ -1,10 +1,22 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel ui.gadgets ui.gestures namespaces ;
USING: kernel accessors ui.gadgets ui.gestures namespaces ;
IN: ui.clipboards IN: ui.clipboards
! Two text transfer buffers ! Two text transfer buffers
TUPLE: clipboard contents ; TUPLE: clipboard contents ;
GENERIC: clipboard-contents ( clipboard -- string )
GENERIC: set-clipboard-contents ( string clipboard -- )
M: clipboard clipboard-contents contents>> ;
M: clipboard set-clipboard-contents (>>contents) ;
: <clipboard> ( -- clipboard ) "" clipboard boa ; : <clipboard> ( -- clipboard ) "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- ) GENERIC: paste-clipboard ( gadget clipboard -- )
@ -20,11 +32,10 @@ SYMBOL: clipboard
SYMBOL: selection SYMBOL: selection
: gadget-copy ( gadget clipboard -- ) : gadget-copy ( gadget clipboard -- )
over gadget-selection? [ over gadget-selection?
>r [ gadget-selection ] keep r> copy-clipboard [ >r [ gadget-selection ] keep r> copy-clipboard ]
] [ [ 2drop ]
2drop if ;
] if ;
: com-copy ( gadget -- ) clipboard get gadget-copy ; : com-copy ( gadget -- ) clipboard get gadget-copy ;

View File

@ -16,12 +16,35 @@ HELP: init-freetype
{ $notes "Do not call this word if you are using the UI." } ; { $notes "Do not call this word if you are using the UI." } ;
HELP: font HELP: font
{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
{ $list { $class-description
{ { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
{ { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." } "A font which has been loaded by FreeType. Font instances have the following slots:"
{ { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
} {
$list
{
{ $snippet "ascent" } ", "
{ $snippet "descent" } ", "
{ $snippet "height" } " - metrics."
}
{
{ $snippet "handle" }
" - alien pointer to an "
{ $snippet "FT_Face" } "."
}
{
{ $snippet "widths" }
" - sequence of character widths. Use "
{ $snippet "width" }
" and "
{ $snippet "width" }
" to compute string widths instead of reading this sequence directly."
}
}
} ; } ;
HELP: close-freetype HELP: close-freetype

View File

@ -33,7 +33,7 @@ ascent descent height handle widths ;
M: font hashcode* drop font hashcode* ; M: font hashcode* drop font hashcode* ;
: close-font ( font -- ) font-handle FT_Done_Face ; : close-font ( font -- ) handle>> FT_Done_Face ;
: close-freetype ( -- ) : close-freetype ( -- )
global [ global [
@ -111,11 +111,11 @@ M: freetype-renderer open-font ( font -- open-font )
freetype drop open-fonts get [ <font> ] cache ; freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph ) : load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char >r handle>> dup r> 0 FT_Load_Char
freetype-error face-glyph ; freetype-error face-glyph ;
: char-width ( open-font char -- w ) : char-width ( open-font char -- w )
over font-widths [ over widths>> [
dupd load-glyph glyph-hori-advance ft-ceil dupd load-glyph glyph-hori-advance ft-ceil
] cache nip ; ] cache nip ;
@ -123,7 +123,7 @@ M: freetype-renderer string-width ( open-font string -- w )
0 -rot [ char-width + ] with each ; 0 -rot [ char-width + ] with each ;
M: freetype-renderer string-height ( open-font string -- h ) M: freetype-renderer string-height ( open-font string -- h )
drop font-height ; drop height>> ;
: glyph-size ( glyph -- dim ) : glyph-size ( glyph -- dim )
dup glyph-hori-advance ft-ceil dup glyph-hori-advance ft-ceil
@ -166,7 +166,7 @@ M: freetype-renderer string-height ( open-font string -- h )
: glyph-texture-loc ( glyph font -- loc ) : glyph-texture-loc ( glyph font -- loc )
over glyph-hori-bearing-x ft-floor -rot over glyph-hori-bearing-x ft-floor -rot
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ; ascent>> swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim ) : glyph-texture-size ( glyph -- dim )
[ glyph-bitmap-width next-power-of-2 ] [ glyph-bitmap-width next-power-of-2 ]

View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.gadgets models ;
IN: ui.gadgets.books IN: ui.gadgets.books
HELP: book HELP: book
{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget." { $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $snippet "visible?" } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
$nl $nl
"Books are created by calling " { $link <book> } "." } ; "Books are created by calling " { $link <book> } "." } ;

View File

@ -5,7 +5,7 @@ IN: ui.gadgets.books
TUPLE: book < gadget ; TUPLE: book < gadget ;
: hide-all ( book -- ) gadget-children [ hide-gadget ] each ; : hide-all ( book -- ) children>> [ hide-gadget ] each ;
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ; : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;

View File

@ -5,7 +5,7 @@ IN: ui.gadgets.buttons
HELP: button HELP: button
{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation." { $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
$nl $nl
"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "." "A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-paint } "."
$nl $nl
"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ; "A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;

View File

@ -119,9 +119,9 @@ M: checkmark-paint draw-interior
black <solid> black <solid>
black <checkmark-paint> black <checkmark-paint>
<button-paint> <button-paint>
over set-gadget-interior over (>>interior)
black <solid> black <solid>
swap set-gadget-boundary ; swap (>>boundary) ;
: <checkmark> ( -- gadget ) : <checkmark> ( -- gadget )
<gadget> <gadget>
@ -165,9 +165,9 @@ M: radio-paint draw-boundary
black <radio-paint> black <radio-paint>
black <radio-paint> black <radio-paint>
<button-paint> <button-paint>
over set-gadget-interior over (>>interior)
black <radio-paint> black <radio-paint>
swap set-gadget-boundary ; swap (>>boundary) ;
: <radio-knob> ( -- gadget ) : <radio-knob> ( -- gadget )
<gadget> <gadget>

View File

@ -38,12 +38,12 @@ focused? ;
: activate-editor-model ( editor model -- ) : activate-editor-model ( editor model -- )
2dup add-connection 2dup add-connection
dup activate-model dup activate-model
swap gadget-model add-loc ; swap model>> add-loc ;
: deactivate-editor-model ( editor model -- ) : deactivate-editor-model ( editor model -- )
2dup remove-connection 2dup remove-connection
dup deactivate-model dup deactivate-model
swap gadget-model remove-loc ; swap model>> remove-loc ;
M: editor graft* M: editor graft*
dup dup
@ -60,11 +60,11 @@ M: editor ungraft*
: editor-mark* ( editor -- loc ) editor-mark model-value ; : editor-mark* ( editor -- loc ) editor-mark model-value ;
: set-caret ( loc editor -- ) : set-caret ( loc editor -- )
[ gadget-model validate-loc ] keep [ model>> validate-loc ] keep
editor-caret set-model ; editor-caret set-model ;
: change-caret ( editor quot -- ) : change-caret ( editor quot -- )
over >r >r dup editor-caret* swap gadget-model r> call r> over >r >r dup editor-caret* swap model>> r> call r>
set-caret ; inline set-caret ; inline
: mark>caret ( editor -- ) : mark>caret ( editor -- )
@ -81,7 +81,7 @@ M: editor ungraft*
editor-font* "" string-height ; editor-font* "" string-height ;
: y>line ( y editor -- line# ) : y>line ( y editor -- line# )
[ line-height / >fixnum ] keep gadget-model validate-line ; [ line-height / >fixnum ] keep model>> validate-line ;
: point>loc ( point editor -- loc ) : point>loc ( point editor -- loc )
[ [
@ -121,7 +121,7 @@ M: editor ungraft*
line-height 0 swap 2array ; line-height 0 swap 2array ;
: scroll>caret ( editor -- ) : scroll>caret ( editor -- )
dup gadget-graft-state second [ dup graft-state>> second [
dup caret-loc over caret-dim { 1 0 } v+ <rect> dup caret-loc over caret-dim { 1 0 } v+ <rect>
over scroll>rect over scroll>rect
] when drop ; ] when drop ;
@ -157,7 +157,7 @@ M: editor ungraft*
swap swap
dup first-visible-line \ first-visible-line set dup first-visible-line \ first-visible-line set
dup last-visible-line \ last-visible-line set dup last-visible-line \ last-visible-line set
dup gadget-model document set dup model>> document set
editor set editor set
call call
] with-scope ; inline ] with-scope ; inline
@ -227,19 +227,19 @@ M: editor gadget-selection?
selection-start/end = not ; selection-start/end = not ;
M: editor gadget-selection M: editor gadget-selection
[ selection-start/end ] keep gadget-model doc-range ; [ selection-start/end ] keep model>> doc-range ;
: remove-selection ( editor -- ) : remove-selection ( editor -- )
[ selection-start/end ] keep gadget-model remove-doc-range ; [ selection-start/end ] keep model>> remove-doc-range ;
M: editor user-input* M: editor user-input*
[ selection-start/end ] keep gadget-model set-doc-range t ; [ selection-start/end ] keep model>> set-doc-range t ;
: editor-string ( editor -- string ) : editor-string ( editor -- string )
gadget-model doc-string ; model>> doc-string ;
: set-editor-string ( string editor -- ) : set-editor-string ( string editor -- )
gadget-model set-doc-string ; model>> set-doc-string ;
M: editor gadget-text* editor-string % ; M: editor gadget-text* editor-string % ;
@ -257,12 +257,12 @@ M: editor gadget-text* editor-string % ;
: drag-selection-caret ( loc editor element -- loc ) : drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep >r [ drag-direction? ] 2keep
gadget-model model>>
r> prev/next-elt ? ; r> prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc ) : drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep >r [ drag-direction? not ] 2keep
nip dup editor-mark* swap gadget-model nip dup editor-mark* swap model>>
r> prev/next-elt ? ; r> prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark ) : drag-caret&mark ( editor -- caret mark )
@ -282,8 +282,8 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [ over gadget-selection? [
drop nip remove-selection drop nip remove-selection
] [ ] [
over >r >r dup editor-caret* swap gadget-model over >r >r dup editor-caret* swap model>>
r> call r> gadget-model remove-doc-range r> call r> model>> remove-doc-range
] if ; inline ] if ; inline
: editor-delete ( editor elt -- ) : editor-delete ( editor elt -- )
@ -309,7 +309,7 @@ M: editor gadget-text* editor-string % ;
: select-elt ( editor elt -- ) : select-elt ( editor elt -- )
over >r over >r
>r dup editor-caret* swap gadget-model r> prev/next-elt >r dup editor-caret* swap model>> r> prev/next-elt
r> editor-select ; r> editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ;

View File

@ -31,7 +31,7 @@ HELP: user-input*
HELP: children-on HELP: children-on
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } } { $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." } { $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ; { $notes "This does not have to be an accurate intersection test, and simply returning " { $snippet "children" } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
HELP: pick-up HELP: pick-up
{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } } { $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
@ -57,7 +57,7 @@ HELP: gadget-selection
HELP: relayout HELP: relayout
{ $values { "gadget" gadget } } { $values { "gadget" gadget } }
{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ; { $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $snippet "root?" } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
HELP: relayout-1 HELP: relayout-1
{ $values { "gadget" gadget } } { $values { "gadget" gadget } }
@ -170,7 +170,7 @@ HELP: focusable-child
{ $values { "gadget" gadget } { "child" gadget } } { $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ; { $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
{ control-value set-control-value gadget-model } related-words { control-value set-control-value } related-words
HELP: control-value HELP: control-value
{ $values { "control" gadget } { "value" object } } { $values { "control" gadget } { "value" object } }
@ -181,10 +181,9 @@ HELP: set-control-value
{ $description "Sets the value of the control's model." } ; { $description "Sets the value of the control's model." } ;
ARTICLE: "ui-control-impl" "Implementing controls" ARTICLE: "ui-control-impl" "Implementing controls"
"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance." "A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $snippet "model" } " slot set to a " { $link model } " instance."
$nl $nl
"Some utility words useful in control implementations:" "Some utility words useful in control implementations:"
{ $subsection gadget-model }
{ $subsection control-value } { $subsection control-value }
{ $subsection set-control-value } { $subsection set-control-value }
{ $see-also "models" } ; { $see-also "models" } ;

View File

@ -150,7 +150,7 @@ DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over (>>layout-state) \ invalidate* over (>>layout-state)
dup forget-pref-dim dup forget-pref-dim
dup gadget-root? dup root?>>
[ layout-later ] [ parent>> [ relayout ] when* ] if ; [ layout-later ] [ parent>> [ relayout ] when* ] if ;
: relayout ( gadget -- ) : relayout ( gadget -- )

View File

@ -77,13 +77,14 @@ M: grid pref-dim*
M: grid layout* dup compute-grid grid-layout ; M: grid layout* dup compute-grid grid-layout ;
M: grid children-on ( rect gadget -- seq ) M: grid children-on ( rect gadget -- seq )
dup gadget-children empty? [ dup children>> empty?
2drop f [ 2drop f ]
] [ [
{ 0 1 } swap grid>> { 0 1 } swap grid>>
[ 0 <column> fast-children-on ] keep [ 0 <column> fast-children-on ] keep
<slice> concat <slice> concat
] if ; ]
if ;
M: grid gadget-text* M: grid gadget-text*
grid>> grid>>

View File

@ -23,7 +23,7 @@ TUPLE: incremental < pack cursor ;
{ 0 0 } >>cursor ; { 0 0 } >>cursor ;
M: incremental pref-dim* M: incremental pref-dim*
dup gadget-layout-state [ dup layout-state>> [
dup call-next-method over set-incremental-cursor dup call-next-method over set-incremental-cursor
] when incremental-cursor ; ] when incremental-cursor ;
@ -31,13 +31,13 @@ M: incremental pref-dim*
[ [
swap rect-dim swap incremental-cursor swap rect-dim swap incremental-cursor
2dup v+ >r vmax r> 2dup v+ >r vmax r>
] keep gadget-orientation set-axis ; ] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- ) : update-cursor ( gadget incremental -- )
[ next-cursor ] keep set-incremental-cursor ; [ next-cursor ] keep set-incremental-cursor ;
: incremental-loc ( gadget incremental -- ) : incremental-loc ( gadget incremental -- )
dup incremental-cursor swap gadget-orientation v* dup incremental-cursor swap orientation>> v*
swap set-rect-loc ; swap set-rect-loc ;
: prefer-incremental ( gadget -- ) : prefer-incremental ( gadget -- )
@ -51,11 +51,11 @@ M: incremental pref-dim*
2dup incremental-loc 2dup incremental-loc
tuck update-cursor tuck update-cursor
dup prefer-incremental dup prefer-incremental
gadget-parent [ invalidate* ] when* ; parent>> [ invalidate* ] when* ;
: clear-incremental ( incremental -- ) : clear-incremental ( incremental -- )
not-in-layout not-in-layout
dup (clear-gadget) dup (clear-gadget)
dup forget-pref-dim dup forget-pref-dim
{ 0 0 } over set-incremental-cursor { 0 0 } over set-incremental-cursor
gadget-parent [ relayout ] when* ; parent>> [ relayout ] when* ;

View File

@ -29,11 +29,11 @@ M: labelled-gadget focusable-child* labelled-gadget-content ;
gray close-box <polygon-gadget> swap <bevel-button> ; gray close-box <polygon-gadget> swap <bevel-button> ;
: title-theme ( gadget -- ) : title-theme ( gadget -- )
{ 1 0 } over set-gadget-orientation { 1 0 } over (>>orientation)
T{ gradient f { T{ gradient f {
T{ rgba f 0.65 0.65 1.0 1.0 } T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 } T{ rgba f 0.65 0.45 1.0 1.0 }
} } swap set-gadget-interior ; } } swap (>>interior) ;
: <title-label> ( text -- label ) <label> dup title-theme ; : <title-label> ( text -- label ) <label> dup title-theme ;

View File

@ -53,7 +53,7 @@ M: list model-changed
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )
dup list-index swap gadget-children ?nth ; dup list-index swap children>> ?nth ;
M: list draw-gadget* M: list draw-gadget*
origin get [ origin get [
@ -98,7 +98,7 @@ M: list focusable-child* drop t ;
] if ; ] if ;
: select-gadget ( gadget list -- ) : select-gadget ( gadget list -- )
swap over gadget-children index swap over children>> index
[ swap select-index ] [ drop ] if* ; [ swap select-index ] [ drop ] if* ;
: clamp-loc ( point max -- point ) : clamp-loc ( point max -- point )

View File

@ -15,7 +15,7 @@ ARTICLE: "ui-pack-layout" "Pack layouts"
{ $subsection pack-layout } ; { $subsection pack-layout } ;
HELP: pack HELP: pack
{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:" { $class-description "A gadget which lays out its children along a single axis stored in the " { $snippet "orientation" } " slot. Can be constructed with one of the following words:"
{ $list { $list
{ $link <pack> } { $link <pack> }
{ $link <pile> } { $link <pile> }
@ -31,7 +31,7 @@ HELP: pack
HELP: pack-layout HELP: pack-layout
{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } } { $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." } { $description "Lays out the pack's children along the " { $snippet "orientation" } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
{ $notes { $notes
"This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure." "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
} ; } ;

View File

@ -30,7 +30,7 @@ TUPLE: pack < gadget
nip ; nip ;
: pack-layout ( pack sizes -- ) : pack-layout ( pack sizes -- )
round-dims over gadget-children round-dims over children>>
>r dupd packed-dims r> 2dup [ (>>dim) ] 2each >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
>r packed-locs r> [ set-rect-loc ] 2each ; >r packed-locs r> [ set-rect-loc ] 2each ;
@ -49,14 +49,14 @@ TUPLE: pack < gadget
: pack-pref-dim ( gadget sizes -- dim ) : pack-pref-dim ( gadget sizes -- dim )
over pack-gap over gap-dims >r max-dim r> over pack-gap over gap-dims >r max-dim r>
rot gadget-orientation set-axis ; rot orientation>> set-axis ;
M: pack pref-dim* M: pack pref-dim*
dup gadget-children pref-dims pack-pref-dim ; dup children>> pref-dims pack-pref-dim ;
M: pack layout* M: pack layout*
dup gadget-children pref-dims pack-layout ; dup children>> pref-dims pack-layout ;
M: pack children-on ( rect gadget -- seq ) M: pack children-on ( rect gadget -- seq )
dup gadget-orientation swap gadget-children dup orientation>> swap children>>
[ fast-children-on ] keep <slice> ; [ fast-children-on ] keep <slice> ;

View File

@ -83,7 +83,7 @@ TUPLE: pane-stream pane ;
C: <pane-stream> pane-stream C: <pane-stream> pane-stream
: smash-line ( current -- gadget ) : smash-line ( current -- gadget )
dup gadget-children { dup children>> {
{ [ dup empty? ] [ 2drop "" <label> ] } { [ dup empty? ] [ 2drop "" <label> ] }
{ [ dup length 1 = ] [ nip first ] } { [ dup length 1 = ] [ nip first ] }
[ drop ] [ drop ]
@ -121,7 +121,7 @@ M: style-stream write-gadget
output-stream get print-gadget ; output-stream get print-gadget ;
: ?nl ( stream -- ) : ?nl ( stream -- )
dup pane-stream-pane pane-current gadget-children empty? dup pane-stream-pane pane-current children>> empty?
[ dup stream-nl ] unless drop ; [ dup stream-nl ] unless drop ;
: with-pane ( pane quot -- ) : with-pane ( pane quot -- )
@ -258,7 +258,7 @@ M: pane-stream make-block-stream
table-gap [ over set-grid-gap ] apply-style ; table-gap [ over set-grid-gap ] apply-style ;
: apply-table-border-style ( style grid -- style grid ) : apply-table-border-style ( style grid -- style grid )
table-border [ <grid-lines> over set-gadget-boundary ] table-border [ <grid-lines> over (>>boundary) ]
apply-style ; apply-style ;
: styled-grid ( style grid -- grid ) : styled-grid ( style grid -- grid )
@ -336,7 +336,7 @@ M: pack sloppy-pick-up* ( loc gadget -- n )
[ orientation>> ] [ children>> ] bi (fast-children-on) ; [ orientation>> ] [ children>> ] bi (fast-children-on) ;
M: gadget sloppy-pick-up* M: gadget sloppy-pick-up*
gadget-children [ inside? ] with find-last drop ; children>> [ inside? ] with find-last drop ;
M: f sloppy-pick-up* M: f sloppy-pick-up*
2drop f ; 2drop f ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov ! Copyright (C) 2005, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render kernel math
namespaces sequences math.order math.geometry.rect ; namespaces sequences math.order math.geometry.rect ;
IN: ui.gadgets.paragraphs IN: ui.gadgets.paragraphs
@ -17,7 +17,7 @@ TUPLE: paragraph < gadget margin ;
: <paragraph> ( margin -- gadget ) : <paragraph> ( margin -- gadget )
paragraph new-gadget paragraph new-gadget
{ 1 0 } over set-gadget-orientation { 1 0 } over (>>orientation)
[ set-paragraph-margin ] keep ; [ set-paragraph-margin ] keep ;
SYMBOL: x SYMBOL: max-x SYMBOL: x SYMBOL: max-x

View File

@ -56,6 +56,6 @@ ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
{ $subsection slide-by } { $subsection slide-by }
{ $subsection slide-by-line } { $subsection slide-by-line }
{ $subsection slide-by-page } { $subsection slide-by-page }
"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ; "Since sliders are controls the value can be get and set by via the " { $snippet "model" } " slot. " ;
ABOUT: "ui.gadgets.sliders" ABOUT: "ui.gadgets.sliders"

View File

@ -20,16 +20,16 @@ TUPLE: slider < frame elevator thumb saved line ;
: min-thumb-dim 15 ; : min-thumb-dim 15 ;
: slider-value ( gadget -- n ) gadget-model range-value >fixnum ; : slider-value ( gadget -- n ) model>> range-value >fixnum ;
: slider-page ( gadget -- n ) gadget-model range-page-value ; : slider-page ( gadget -- n ) model>> range-page-value ;
: slider-max ( gadget -- n ) gadget-model range-max-value ; : slider-max ( gadget -- n ) model>> range-max-value ;
: slider-max* ( gadget -- n ) gadget-model range-max-value* ; : slider-max* ( gadget -- n ) model>> range-max-value* ;
: thumb-dim ( slider -- h ) : thumb-dim ( slider -- h )
dup slider-page over slider-max 1 max / 1 min dup slider-page over slider-max 1 max / 1 min
over elevator-length * min-thumb-dim max over elevator-length * min-thumb-dim max
over slider-elevator rect-dim over slider-elevator rect-dim
rot gadget-orientation v. min ; rot orientation>> v. min ;
: slider-scale ( slider -- n ) : slider-scale ( slider -- n )
#! A scaling factor such that if x is a slider co-ordinate, #! A scaling factor such that if x is a slider co-ordinate,
@ -49,9 +49,9 @@ TUPLE: thumb < gadget ;
find-slider dup slider-value swap set-slider-saved ; find-slider dup slider-value swap set-slider-saved ;
: do-drag ( thumb -- ) : do-drag ( thumb -- )
find-slider drag-loc over gadget-orientation v. find-slider drag-loc over orientation>> v.
over screen>slider swap [ slider-saved + ] keep over screen>slider swap [ slider-saved + ] keep
gadget-model set-range-value ; model>> set-range-value ;
thumb H{ thumb H{
{ T{ button-down } [ begin-drag ] } { T{ button-down } [ begin-drag ] }
@ -69,13 +69,13 @@ thumb H{
t >>root? t >>root?
thumb-theme ; thumb-theme ;
: slide-by ( amount slider -- ) gadget-model move-by ; : slide-by ( amount slider -- ) model>> move-by ;
: slide-by-page ( amount slider -- ) gadget-model move-by-page ; : slide-by-page ( amount slider -- ) model>> move-by-page ;
: compute-direction ( elevator -- -1/1 ) : compute-direction ( elevator -- -1/1 )
dup find-slider swap hand-click-rel dup find-slider swap hand-click-rel
over gadget-orientation v. over orientation>> v.
over screen>slider over screen>slider
swap slider-value - sgn ; swap slider-value - sgn ;
@ -97,7 +97,7 @@ elevator H{
lowered-gradient >>interior ; lowered-gradient >>interior ;
: (layout-thumb) ( slider n -- n thumb ) : (layout-thumb) ( slider n -- n thumb )
over gadget-orientation n*v swap slider-thumb ; over orientation>> n*v swap slider-thumb ;
: thumb-loc ( slider -- loc ) : thumb-loc ( slider -- loc )
dup slider-value swap slider>screen ; dup slider-value swap slider>screen ;
@ -109,7 +109,7 @@ elevator H{
: layout-thumb-dim ( slider -- ) : layout-thumb-dim ( slider -- )
dup dup thumb-dim (layout-thumb) >r dup dup thumb-dim (layout-thumb) >r
>r dup rect-dim r> >r dup rect-dim r>
rot gadget-orientation set-axis [ ceiling ] map rot orientation>> set-axis [ ceiling ] map
r> (>>dim) ; r> (>>dim) ;
: layout-thumb ( slider -- ) : layout-thumb ( slider -- )
@ -124,7 +124,7 @@ M: elevator layout*
: <slide-button> ( vector polygon amount -- button ) : <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r> >r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button> [ swap find-slider slide-by-line ] curry <repeat-button>
[ set-gadget-orientation ] keep ; [ (>>orientation) ] keep ;
: elevator, ( gadget orientation -- gadget ) : elevator, ( gadget orientation -- gadget )
tuck <elevator> >>elevator tuck <elevator> >>elevator
@ -157,5 +157,5 @@ M: elevator layout*
M: slider pref-dim* M: slider pref-dim*
dup call-next-method dup call-next-method
swap gadget-orientation [ 40 v*n ] keep swap orientation>> [ 40 v*n ] keep
set-axis ; set-axis ;

View File

@ -11,7 +11,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
{ $subsection track-add } ; { $subsection track-add } ;
HELP: track HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ; { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $snippet "orientation" } ". Tracks are created by calling " { $link <track> } "." } ;
HELP: <track> HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } } { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }

View File

@ -31,7 +31,7 @@ M: viewport focusable-child*
M: viewport pref-dim* viewport-dim ; M: viewport pref-dim* viewport-dim ;
: scroller-value ( scroller -- loc ) : scroller-value ( scroller -- loc )
gadget-model range-value [ >fixnum ] map ; model>> range-value [ >fixnum ] map ;
M: viewport model-changed M: viewport model-changed
nip nip
@ -41,8 +41,7 @@ M: viewport model-changed
swap gadget-child set-rect-loc ; swap gadget-child set-rect-loc ;
: visible-dim ( gadget -- dim ) : visible-dim ( gadget -- dim )
dup gadget-parent viewport? [ dup parent>> viewport?
gadget-parent rect-dim viewport-gap 2 v*n v- [ parent>> rect-dim viewport-gap 2 v*n v- ]
] [ [ rect-dim ]
rect-dim if ;
] if ;

View File

@ -23,8 +23,8 @@ M: f world-status ;
: hide-status ( gadget -- ) f swap show-status ; : hide-status ( gadget -- ) f swap show-status ;
: (request-focus) ( child world ? -- ) : (request-focus) ( child world ? -- )
pick gadget-parent pick eq? [ pick parent>> pick eq? [
>r >r dup gadget-parent dup r> r> >r >r dup parent>> dup r> r>
[ (request-focus) ] keep [ (request-focus) ] keep
] unless focus-child ; ] unless focus-child ;
@ -51,7 +51,7 @@ M: world layout*
M: world focusable-child* gadget-child ; M: world focusable-child* gadget-child ;
M: world children-on nip gadget-children ; M: world children-on nip children>> ;
: (draw-world) ( world -- ) : (draw-world) ( world -- )
dup world-handle [ dup world-handle [

View File

@ -157,15 +157,15 @@ SYMBOL: drag-timer
: focus-child ( child gadget ? -- ) : focus-child ( child gadget ? -- )
[ [
dup gadget-focus [ dup focus>> [
dup send-lose-focus dup send-lose-focus
f swap t focus-child f swap t focus-child
] when* ] when*
dupd set-gadget-focus [ dupd (>>focus) [
send-gain-focus send-gain-focus
] when* ] when*
] [ ] [
set-gadget-focus (>>focus)
] if ; ] if ;
: modifier ( mod modifiers -- seq ) : modifier ( mod modifiers -- seq )
@ -244,7 +244,7 @@ SYMBOL: drag-timer
drop ; drop ;
: world-focus ( world -- gadget ) : world-focus ( world -- gadget )
dup gadget-focus [ world-focus ] [ ] ?if ; dup focus>> [ world-focus ] [ ] ?if ;
: send-action ( world gesture -- ) : send-action ( world gesture -- )
swap world-focus send-gesture drop ; swap world-focus send-gesture drop ;

View File

@ -31,17 +31,17 @@ HELP: draw-gadget*
HELP: draw-interior HELP: draw-interior
{ $values { "interior" object } { "gadget" gadget } } { $values { "interior" object } { "gadget" gadget } }
{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ; { $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
HELP: draw-boundary HELP: draw-boundary
{ $values { "boundary" object } { "gadget" gadget } } { $values { "boundary" object } { "gadget" gadget } }
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ; { $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
HELP: solid HELP: solid
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ; { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
HELP: gradient HELP: gradient
{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ; { $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
HELP: polygon HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:" { $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
@ -94,17 +94,17 @@ ARTICLE: "gadgets-polygons" "Polygon gadgets"
ARTICLE: "ui-paint" "Customizing gadget appearance" ARTICLE: "ui-paint" "Customizing gadget appearance"
"The UI carries out the following steps when drawing a gadget:" "The UI carries out the following steps when drawing a gadget:"
{ $list { $list
{ "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." } { "The " { $link draw-interior } " generic word is called on the value of the " { $snippet "interior" } " slot." }
{ "The " { $link draw-gadget* } " generic word is called on the gadget." } { "The " { $link draw-gadget* } " generic word is called on the gadget." }
{ "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." } { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." }
{ "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." } { "The " { $link draw-boundary } " generic word is called on the value of the " { $snippet "boundary" } " slot." }
} }
"Now, each one of these steps will be covered in detail." "Now, each one of these steps will be covered in detail."
{ $subsection "ui-pen-protocol" } { $subsection "ui-pen-protocol" }
{ $subsection "ui-paint-custom" } ; { $subsection "ui-paint-custom" } ;
ARTICLE: "ui-pen-protocol" "UI pen protocol" ARTICLE: "ui-pen-protocol" "UI pen protocol"
"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:" "The " { $snippet "interior" } " and " { $snippet "boundary" } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
{ $subsection draw-interior } { $subsection draw-interior }
{ $subsection draw-boundary } { $subsection draw-boundary }
"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing." "The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
@ -139,7 +139,7 @@ $nl
$nl $nl
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." "OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
$nl $nl
"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor." "Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $snippet "clipped?" } " slot to " { $link t } " in the gadget's constructor."
$nl $nl
"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section." "Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
{ $subsection "gl-utilities" } { $subsection "gl-utilities" }

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays hashtables io kernel math namespaces opengl USING: accessors alien arrays hashtables io kernel math namespaces opengl
opengl.gl opengl.glu sequences strings io.styles vectors opengl.gl opengl.glu sequences strings io.styles vectors
combinators math.vectors ui.gadgets colors combinators math.vectors ui.gadgets colors
math.order math.geometry.rect ; math.order math.geometry.rect ;
@ -60,10 +60,10 @@ DEFER: draw-gadget
: (draw-gadget) ( gadget -- ) : (draw-gadget) ( gadget -- )
[ [
dup translate dup translate
dup dup gadget-interior draw-interior dup dup interior>> draw-interior
dup draw-gadget* dup draw-gadget*
dup visible-children [ draw-gadget ] each dup visible-children [ draw-gadget ] each
dup gadget-boundary draw-boundary dup boundary>> draw-boundary
] with-scope ; ] with-scope ;
: >absolute ( rect -- rect ) : >absolute ( rect -- rect )
@ -79,8 +79,8 @@ DEFER: draw-gadget
: draw-gadget ( gadget -- ) : draw-gadget ( gadget -- )
{ {
{ [ dup gadget-visible? not ] [ drop ] } { [ dup visible?>> not ] [ drop ] }
{ [ dup gadget-clipped? not ] [ (draw-gadget) ] } { [ dup clipped?>> not ] [ (draw-gadget) ] }
[ [ (draw-gadget) ] with-clipping ] [ [ (draw-gadget) ] with-clipping ]
} cond ; } cond ;
@ -108,7 +108,7 @@ C: <gradient> gradient
M: gradient draw-interior M: gradient draw-interior
origin get [ origin get [
over gadget-orientation over orientation>>
swap gradient-colors swap gradient-colors
rot rect-dim rot rect-dim
gl-gradient gl-gradient
@ -139,7 +139,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget ) : <polygon-gadget> ( color points -- gadget )
dup max-dim dup max-dim
>r <polygon> <gadget> r> over set-rect-dim >r <polygon> <gadget> r> over set-rect-dim
[ set-gadget-interior ] keep ; [ (>>interior) ] keep ;
! Font rendering ! Font rendering
SYMBOL: font-renderer SYMBOL: font-renderer

View File

@ -57,7 +57,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
advanced-settings advanced-settings
deploy-settings-theme deploy-settings-theme
namespace <mapping> over set-gadget-model namespace <mapping> over (>>model)
] ]
bind ; bind ;

View File

@ -54,7 +54,7 @@ M: interactor ungraft*
: word-at-loc ( loc interactor -- word ) : word-at-loc ( loc interactor -- word )
over [ over [
[ gadget-model T{ one-word-elt } elt-string ] keep [ model>> T{ one-word-elt } elt-string ] keep
interactor-use assoc-stack interactor-use assoc-stack
] [ ] [
2drop f 2drop f
@ -82,7 +82,7 @@ M: interactor model-changed
: interactor-continue ( obj interactor -- ) : interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ; mailbox>> mailbox-put ;
: clear-input ( interactor -- ) gadget-model clear-doc ; : clear-input ( interactor -- ) model>> clear-doc ;
: interactor-finish ( interactor -- ) : interactor-finish ( interactor -- )
#! The spawn is a kludge to make it infer. Stupid. #! The spawn is a kludge to make it infer. Stupid.

View File

@ -46,7 +46,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
<namestack-display> { 400 400 } <limited-scroller> ; <namestack-display> { 400 400 } <limited-scroller> ;
: variables ( traceback -- ) : variables ( traceback -- )
gadget-model <variables-gadget> model>> <variables-gadget>
"Dynamic variables" open-status-window ; "Dynamic variables" open-status-window ;
: traceback-window ( continuation -- ) : traceback-window ( continuation -- )

View File

@ -29,7 +29,7 @@ M: gadget tool-scroller drop f ;
book>> children>> [ class eq? ] with find ; book>> children>> [ class eq? ] with find ;
: show-tool ( class workspace -- tool ) : show-tool ( class workspace -- tool )
[ find-tool swap ] keep workspace-book gadget-model [ find-tool swap ] keep workspace-book model>>
set-model ; set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ; : select-tool ( workspace class -- ) swap show-tool drop ;

View File

@ -1,13 +1,13 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences kernel math arrays io ui.gadgets USING: accessors namespaces sequences kernel math arrays io ui.gadgets
generic combinators ; generic combinators ;
IN: ui.traverse IN: ui.traverse
TUPLE: node value children ; TUPLE: node value children ;
: traverse-step ( path gadget -- path' gadget' ) : traverse-step ( path gadget -- path' gadget' )
>r unclip r> gadget-children ?nth ; >r unclip r> children>> ?nth ;
: make-node ( quot -- ) { } make node boa , ; inline : make-node ( quot -- ) { } make node boa , ; inline
@ -19,7 +19,7 @@ TUPLE: node value children ;
nip , nip ,
] [ ] [
[ [
2dup gadget-children swap first head-slice % 2dup children>> swap first head-slice %
tuck traverse-step traverse-to-path tuck traverse-step traverse-to-path
] make-node ] make-node
] if ] if
@ -34,7 +34,7 @@ TUPLE: node value children ;
] [ ] [
[ [
2dup traverse-step traverse-from-path 2dup traverse-step traverse-from-path
tuck gadget-children swap first 1+ tail-slice % tuck children>> swap first 1+ tail-slice %
] make-node ] make-node
] if ] if
] if ; ] if ;
@ -43,7 +43,7 @@ TUPLE: node value children ;
traverse-step traverse-from-path ; traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- ) : (traverse-middle) ( frompath topath gadget -- )
>r >r first 1+ r> first r> gadget-children <slice> % ; >r >r first 1+ r> first r> children>> <slice> % ;
: traverse-post ( topath gadget -- ) : traverse-post ( topath gadget -- )
traverse-step traverse-to-path ; traverse-step traverse-to-path ;

View File

@ -83,7 +83,7 @@ ARTICLE: "ui-glossary" "UI glossary"
ARTICLE: "building-ui" "Building user interfaces" ARTICLE: "building-ui" "Building user interfaces"
"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "." "A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
{ $subsection gadget } { $subsection gadget }
"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot." "Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $snippet "parent" } " slot."
{ $subsection "ui-geometry" } { $subsection "ui-geometry" }
{ $subsection "ui-layouts" } { $subsection "ui-layouts" }
{ $subsection "gadgets" } { $subsection "gadgets" }
@ -119,8 +119,10 @@ ARTICLE: "ui-geometry" "Gadget geometry"
{ $subsection offset-rect } { $subsection offset-rect }
{ $subsection rect-intersect } { $subsection rect-intersect }
{ $subsection intersects? } { $subsection intersects? }
"A gadget's bounding box is always relative to its parent:"
{ $subsection gadget-parent } ! "A gadget's bounding box is always relative to its parent. "
! { $subsection gadget-parent }
"Word for converting from a child gadget's co-ordinate system to a parent's:" "Word for converting from a child gadget's co-ordinate system to a parent's:"
{ $subsection relative-loc } { $subsection relative-loc }
{ $subsection screen-loc } { $subsection screen-loc }
@ -211,8 +213,8 @@ $nl
{ $subsection unparent } { $subsection unparent }
{ $subsection add-gadgets } { $subsection add-gadgets }
{ $subsection clear-gadget } { $subsection clear-gadget }
"Working with gadget children:" "The children of a gadget are available via the "
{ $subsection gadget-children } { $snippet "children" } " slot. " "Working with gadget children:"
{ $subsection gadget-child } { $subsection gadget-child }
{ $subsection nth-gadget } { $subsection nth-gadget }
{ $subsection each-child } { $subsection each-child }

View File

@ -90,21 +90,21 @@ SYMBOL: ui-hook
V{ } clone windows set-global ; V{ } clone windows set-global ;
: restore-gadget-later ( gadget -- ) : restore-gadget-later ( gadget -- )
dup gadget-graft-state { dup graft-state>> {
{ { f f } [ ] } { { f f } [ ] }
{ { f t } [ ] } { { f t } [ ] }
{ { t t } [ { { t t } [
{ f f } over set-gadget-graft-state { f f } over (>>graft-state)
] } ] }
{ { t f } [ { { t f } [
dup unqueue-graft dup unqueue-graft
{ f f } over set-gadget-graft-state { f f } over (>>graft-state)
] } ] }
} case graft-later ; } case graft-later ;
: restore-gadget ( gadget -- ) : restore-gadget ( gadget -- )
dup restore-gadget-later dup restore-gadget-later
gadget-children [ restore-gadget ] each ; children>> [ restore-gadget ] each ;
: restore-world ( world -- ) : restore-world ( world -- )
dup reset-world restore-gadget ; dup reset-world restore-gadget ;
@ -133,9 +133,9 @@ SYMBOL: ui-hook
[ dup update-hand draw-world ] each ; [ dup update-hand draw-world ] each ;
: notify ( gadget -- ) : notify ( gadget -- )
dup gadget-graft-state dup graft-state>>
dup first { f f } { t t } ? dup first { f f } { t t } ?
pick set-gadget-graft-state { pick (>>graft-state) {
{ { f t } [ dup activate-control graft* ] } { { f t } [ dup activate-control graft* ] }
{ { t f } [ dup deactivate-control ungraft* ] } { { t f } [ dup deactivate-control ungraft* ] }
} case ; } case ;

View File

@ -1,6 +1,6 @@
USING: unicode.data sequences sequences.next namespaces USING: unicode.data sequences sequences.next namespaces
unicode.normalize math unicode.categories combinators unicode.normalize math unicode.categories combinators
assocs strings splitting kernel ; assocs strings splitting kernel accessors ;
IN: unicode.case IN: unicode.case
: at-default ( key assoc -- value/key ) over >r at r> or ; : at-default ( key assoc -- value/key ) over >r at r> or ;
@ -91,17 +91,17 @@ SYMBOL: locale ! Just casing locale, or overall?
: >lower ( string -- lower ) : >lower ( string -- lower )
i-dot? [ turk>lower ] when i-dot? [ turk>lower ] when
final-sigma [ code-point-lower ] [ ch>lower ] map-case ; final-sigma [ lower>> ] [ ch>lower ] map-case ;
: >upper ( string -- upper ) : >upper ( string -- upper )
i-dot? [ turk>upper ] when i-dot? [ turk>upper ] when
[ code-point-upper ] [ ch>upper ] map-case ; [ upper>> ] [ ch>upper ] map-case ;
: >title ( string -- title ) : >title ( string -- title )
final-sigma final-sigma
CHAR: \s swap CHAR: \s swap
[ tuck word-boundary swapd [ tuck word-boundary swapd
[ code-point-title ] [ code-point-lower ] if ] [ title>> ] [ lower>> ] if ]
[ tuck word-boundary swapd [ tuck word-boundary swapd
[ ch>title ] [ ch>lower ] if ] [ ch>title ] [ ch>lower ] if ]
map-case nip ; map-case nip ;

View File

@ -1,5 +1,5 @@
USING: sequences namespaces unicode.data kernel math arrays USING: sequences namespaces unicode.data kernel math arrays
locals sorting.insertion ; locals sorting.insertion accessors ;
IN: unicode.normalize IN: unicode.normalize
! Conjoining Jamo behavior ! Conjoining Jamo behavior
@ -43,7 +43,7 @@ IN: unicode.normalize
: reorder-next ( string i -- new-i done? ) : reorder-next ( string i -- new-i done? )
over [ non-starter? ] find-from drop [ over [ non-starter? ] find-from drop [
reorder-slice reorder-slice
>r dup [ combining-class ] insertion-sort slice-to r> >r dup [ combining-class ] insertion-sort to>> r>
] [ length t ] if* ; ] [ length t ] if* ;
: reorder-loop ( string start -- ) : reorder-loop ( string start -- )

View File

@ -216,7 +216,7 @@ SYMBOL: interactive-vocabs
: filter-moved ( assoc1 assoc2 -- seq ) : filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [ swap assoc-diff [
drop where dup [ first ] when drop where dup [ first ] when
file get source-file-path = file get path>> =
] assoc-filter keys ; ] assoc-filter keys ;
: removed-definitions ( -- assoc1 assoc2 ) : removed-definitions ( -- assoc1 assoc2 )

View File

@ -779,19 +779,19 @@ HELP: collapse-slice
HELP: <flat-slice> HELP: <flat-slice>
{ $values { "seq" sequence } { "slice" slice } } { $values { "seq" sequence } { "slice" slice } }
{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $link slice-from } " equal to 0 and " { $link slice-to } " equal to the length of " { $snippet "seq" } "." } { $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $snippet "from" } " equal to 0 and " { $snippet "to" } " equal to the length of " { $snippet "seq" } "." }
{ $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ; { $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
HELP: <slice> HELP: <slice>
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } } { $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } }
{ $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." } { $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." } { $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." }
{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $link slice-from } " and " { $link slice-to } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ; { $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $snippet "from" } " and " { $snippet "to" } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
{ <slice> subseq } related-words { <slice> subseq } related-words
HELP: repetition HELP: repetition
{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ; { $class-description "A virtual sequence consisting of " { $snippet "elt" } " repeated " { $snippet "len" } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
HELP: <repetition> ( len elt -- repetition ) HELP: <repetition> ( len elt -- repetition )
{ $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } } { $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } }

View File

@ -6,15 +6,15 @@ classes slots.private combinators slots ;
IN: slots.deprecated IN: slots.deprecated
: reader-effect ( class spec -- effect ) : reader-effect ( class spec -- effect )
>r ?word-name 1array r> slot-spec-name 1array <effect> ; >r ?word-name 1array r> name>> 1array <effect> ;
PREDICATE: slot-reader < word "reading" word-prop >boolean ; PREDICATE: slot-reader < word "reading" word-prop >boolean ;
: set-reader-props ( class spec -- ) : set-reader-props ( class spec -- )
2dup reader-effect 2dup reader-effect
over slot-spec-reader over reader>>
swap "declared-effect" set-word-prop swap "declared-effect" set-word-prop
slot-spec-reader swap "reading" set-word-prop ; reader>> swap "reading" set-word-prop ;
: define-slot-word ( class word quot -- ) : define-slot-word ( class word quot -- )
[ [
@ -23,9 +23,9 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
] dip define ; ] dip define ;
: define-reader ( class spec -- ) : define-reader ( class spec -- )
dup slot-spec-reader [ dup reader>> [
[ set-reader-props ] 2keep [ set-reader-props ] 2keep
dup slot-spec-reader dup reader>>
swap reader-quot swap reader-quot
define-slot-word define-slot-word
] [ ] [
@ -33,20 +33,20 @@ PREDICATE: slot-reader < word "reading" word-prop >boolean ;
] if ; ] if ;
: writer-effect ( class spec -- effect ) : writer-effect ( class spec -- effect )
slot-spec-name swap ?word-name 2array 0 <effect> ; name>> swap ?word-name 2array 0 <effect> ;
PREDICATE: slot-writer < word "writing" word-prop >boolean ; PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: set-writer-props ( class spec -- ) : set-writer-props ( class spec -- )
2dup writer-effect 2dup writer-effect
over slot-spec-writer over writer>>
swap "declared-effect" set-word-prop swap "declared-effect" set-word-prop
slot-spec-writer swap "writing" set-word-prop ; writer>> swap "writing" set-word-prop ;
: define-writer ( class spec -- ) : define-writer ( class spec -- )
dup slot-spec-writer [ dup writer>> [
[ set-writer-props ] 2keep [ set-writer-props ] 2keep
dup slot-spec-writer dup writer>>
swap writer-quot swap writer-quot
define-slot-word define-slot-word
] [ ] [

View File

@ -30,10 +30,10 @@ HELP: source-file
{ $description "Outputs the source file associated to a path name, creating the source file first if it doesn't exist. Source files are retained in the " { $link source-files } " variable." } { $description "Outputs the source file associated to a path name, creating the source file first if it doesn't exist. Source files are retained in the " { $link source-files } " variable." }
{ $class-description "Instances retain information about loaded source files, and have the following slots:" { $class-description "Instances retain information about loaded source files, and have the following slots:"
{ $list { $list
{ { $link source-file-path } " - a pathname string." } { { $snippet "path" } " - a pathname string." }
{ { $link source-file-checksum } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." } { { $snippet "checksum" } " - the CRC32 checksum of the source file's contents at the time it was most recently loaded." }
{ { $link source-file-uses } " - an assoc whose keys are words referenced from this source file's top level form." } { { $snippet "uses" } " - an assoc whose keys are words referenced from this source file's top level form." }
{ { $link source-file-definitions } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" } { { $snippet "definitions" } " - a pair of assocs, containing definitions and classes defined in this source file, respectively" }
} }
} ; } ;
@ -78,4 +78,4 @@ HELP: rollback-source-file
{ $description "Records information to the source file after an incomplete parse which ended with an error." } ; { $description "Records information to the source file after an incomplete parse which ended with an error." } ;
HELP: file HELP: file
{ $var-description "Stores the " { $link source-file } " being parsed. The " { $link source-file-path } " of this object comes from the input parameter to " { $link with-source-file } "." } ; { $var-description "Stores the " { $link source-file } " being parsed. The " { $snippet "path" } " of this object comes from the input parameter to " { $link with-source-file } "." } ;

View File

@ -15,11 +15,11 @@ checksum
uses definitions ; uses definitions ;
: record-checksum ( lines source-file -- ) : record-checksum ( lines source-file -- )
>r crc32 checksum-lines r> set-source-file-checksum ; [ crc32 checksum-lines ] dip (>>checksum) ;
: (xref-source) ( source-file -- pathname uses ) : (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> [ path>> <pathname> ]
swap source-file-uses [ crossref? ] filter ; [ uses>> [ crossref? ] filter ] bi ;
: xref-source ( source-file -- ) : xref-source ( source-file -- )
(xref-source) crossref get add-vertex ; (xref-source) crossref get add-vertex ;
@ -31,20 +31,22 @@ uses definitions ;
source-files get [ nip xref-source ] assoc-each ; source-files get [ nip xref-source ] assoc-each ;
: record-form ( quot source-file -- ) : record-form ( quot source-file -- )
dup unxref-source tuck unxref-source
swap quot-uses keys over set-source-file-uses quot-uses keys >>uses
xref-source ; xref-source ;
: record-definitions ( file -- ) : record-definitions ( file -- )
new-definitions get swap set-source-file-definitions ; new-definitions get >>definitions drop ;
: <source-file> ( path -- source-file ) : <source-file> ( path -- source-file )
\ source-file new \ source-file new
swap >>path swap >>path
<definitions> >>definitions ; <definitions> >>definitions ;
ERROR: invalid-source-file-path path ;
: source-file ( path -- source-file ) : source-file ( path -- source-file )
dup string? [ "Invalid source file path" throw ] unless dup string? [ invalid-source-file-path ] unless
source-files get [ <source-file> ] cache ; source-files get [ <source-file> ] cache ;
: reset-checksums ( -- ) : reset-checksums ( -- )
@ -70,8 +72,9 @@ M: pathname forget*
pathname-string forget-source ; pathname-string forget-source ;
: rollback-source-file ( file -- ) : rollback-source-file ( file -- )
dup source-file-definitions new-definitions get [ assoc-union ] 2map [
swap set-source-file-definitions ; new-definitions get [ assoc-union ] 2map
] change-definitions drop ;
SYMBOL: file SYMBOL: file
@ -87,7 +90,7 @@ TUPLE: source-file-error file error ;
[ [
swap source-file swap source-file
dup file set dup file set
source-file-definitions old-definitions set definitions>> old-definitions set
[ [
file get rollback-source-file file get rollback-source-file
<source-file-error> rethrow <source-file-error> rethrow

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs namespaces splitting sequences USING: kernel assocs namespaces splitting sequences
strings math.parser lexer ; strings math.parser lexer accessors ;
IN: strings.parser IN: strings.parser
ERROR: bad-escape ; ERROR: bad-escape ;
@ -46,7 +46,7 @@ name>char-hook global [
dup [ "\"\\" member? ] find dup [ dup [ "\"\\" member? ] find dup [
>r cut-slice >r % r> rest-slice r> >r cut-slice >r % r> rest-slice r>
dup CHAR: " = [ dup CHAR: " = [
drop slice-from drop from>>
] [ ] [
drop next-escape >r , r> (parse-string) drop next-escape >r , r> (parse-string)
] if ] if

View File

@ -3,7 +3,7 @@
USING: namespaces sequences io.files kernel assocs words vocabs USING: namespaces sequences io.files kernel assocs words vocabs
definitions parser continuations io hashtables sorting definitions parser continuations io hashtables sorting
source-files arrays combinators strings system math.parser source-files arrays combinators strings system math.parser
compiler.errors splitting init ; compiler.errors splitting init accessors ;
IN: vocabs.loader IN: vocabs.loader
SYMBOL: vocab-roots SYMBOL: vocab-roots
@ -51,32 +51,23 @@ H{ } clone root-cache set-global
SYMBOL: load-help? SYMBOL: load-help?
: source-was-loaded ( vocab -- ) t swap set-vocab-source-loaded? ; : load-source ( vocab -- vocab )
f >>source-loaded?
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
t >>source-loaded?
[ [ % ] [ call ] if-bootstrapping ] dip ;
: source-wasn't-loaded ( vocab -- ) f swap set-vocab-source-loaded? ;
: load-source ( vocab -- ) : load-docs ( vocab -- vocab )
[ source-wasn't-loaded ]
[ vocab-source-path [ parse-file ] [ [ ] ] if* ]
[ source-was-loaded ]
tri
[ % ] [ call ] if-bootstrapping ;
: docs-were-loaded ( vocab -- ) t swap set-vocab-docs-loaded? ;
: docs-weren't-loaded ( vocab -- ) f swap set-vocab-docs-loaded? ;
: load-docs ( vocab -- )
load-help? get [ load-help? get [
[ docs-weren't-loaded ] f >>docs-loaded?
[ vocab-docs-path [ ?run-file ] when* ] [ vocab-docs-path [ ?run-file ] when* ] keep
[ docs-were-loaded ] t >>docs-loaded?
tri ] when ;
] [ drop ] if ;
: reload ( name -- ) : reload ( name -- )
[ [
dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if dup vocab [ load-source load-docs drop ] [ no-vocab ] ?if
] with-compiler-errors ; ] with-compiler-errors ;
: require ( vocab -- ) : require ( vocab -- )
@ -100,8 +91,8 @@ GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab) M: vocab (load-vocab)
[ [
dup vocab-source-loaded? [ dup load-source ] unless dup vocab-source-loaded? [ load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless dup vocab-docs-loaded? [ load-docs ] unless
drop drop
] [ [ swap add-to-blacklist ] keep rethrow ] recover ; ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;

View File

@ -35,8 +35,8 @@ HELP: 24-able ( -- vector )
} }
{ $examples { $examples
{ $example { $example
"USE: 24-game" "USING: 24-game prettyprint ;"
"24-able vector-24-able? ." "24-able 24-able? ."
"t" "t"
} }
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." } { $notes { $link 24-able? } " is used in " { $link 24-able } "." }
@ -54,7 +54,7 @@ HELP: 24-able? ( quad -- t/f )
HELP: build-quad ( -- array ) HELP: build-quad ( -- array )
{ $values { $values
{ "vector" "an array of 4 numbers" } { "array" "an array of 4 numbers" }
} }
{ $description "Builds an array of 4 random numbers." } ; { $description "Builds an array of 4 random numbers." } ;
ARTICLE: "24-game" "The Game of 24" ARTICLE: "24-game" "The Game of 24"
@ -64,4 +64,4 @@ ARTICLE: "24-game" "The Game of 24"
{ $subsection 24-able } { $subsection 24-able }
{ $subsection 24-able? } { $subsection 24-able? }
{ $subsection build-quad } ; { $subsection build-quad } ;
ABOUT: "24-game" ABOUT: "24-game"

View File

@ -150,4 +150,4 @@ MACRO: predicates ( seq -- quot/f )
>r [ [ dup ] prepend ] map r> zip [ drop f ] suffix >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
[ cond ] curry ; [ cond ] curry ;
: %chance ( quot integer -- ) 100 random > swap when ; inline : %chance ( quot n -- ) 100 random > swap when ; inline

View File

@ -84,5 +84,5 @@ DEFER: quoted-field ( -- endchar )
: write-row ( row -- ) : write-row ( row -- )
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
: write-csv ( rows outstream -- ) : write-csv ( rows stream -- )
[ [ write-row ] each ] with-output-stream ; [ [ write-row ] each ] with-output-stream ;

View File

@ -23,7 +23,7 @@ HELP: ctags ( path -- )
} ; } ;
HELP: ctags-write ( seq path -- ) HELP: ctags-write ( seq path -- )
{ $values { "alist" "an association list" } { $values { "seq" sequence }
{ "path" "a pathname string" } } { "path" "a pathname string" } }
{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } { $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
{ $examples { $examples
@ -97,4 +97,4 @@ HELP: ctag-word ( ctag -- word )
} ; } ;
ABOUT: "ctags" ABOUT: "ctags"

View File

@ -84,8 +84,8 @@ SYMBOL: person4
10 10
3.14 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
} }
] [ T{ person f 3 } select-tuple ] unit-test ] [ T{ person f 3 } select-tuple ] unit-test
@ -100,8 +100,8 @@ SYMBOL: person4
10 10
3.14 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f f
H{ { 1 2 } { 3 4 } { 5 "lol" } } H{ { 1 2 } { 3 4 } { 5 "lol" } }
URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search"
@ -129,12 +129,12 @@ SYMBOL: person4
"teddy" 10 3.14 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
"eddie" 10 3.14 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ; f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <person> person4 set ;
: user-assigned-person-schema ( -- ) : user-assigned-person-schema ( -- )
@ -156,13 +156,13 @@ SYMBOL: person4
3 "teddy" 10 3.14 3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 } B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f f <user-assigned-person> person3 set f f <user-assigned-person> person3 set
4 "eddie" 10 3.14 4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ; f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: paste n summary author channel mode contents timestamp annotations ;

View File

@ -127,12 +127,12 @@ M: retryable execute-statement* ( statement type -- )
: insert-db-assigned-statement ( tuple -- ) : insert-db-assigned-statement ( tuple -- )
dup class dup class
db get db-insert-statements [ <insert-db-assigned-statement> ] cache db get insert-statements>> [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ; [ bind-tuple ] 2keep insert-tuple* ;
: insert-user-assigned-statement ( tuple -- ) : insert-user-assigned-statement ( tuple -- )
dup class dup class
db get db-insert-statements [ <insert-user-assigned-statement> ] cache db get insert-statements>> [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )

View File

@ -143,7 +143,7 @@ HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n ) : offset-of-slot ( str obj -- n )
class superclasses [ "slots" word-prop ] map concat class superclasses [ "slots" word-prop ] map concat
slot-named slot-spec-offset ; slot-named offset>> ;
: get-slot-named ( name obj -- value ) : get-slot-named ( name obj -- value )
tuck offset-of-slot slot ; tuck offset-of-slot slot ;

View File

@ -76,16 +76,16 @@ HELP: add-edge*
{ "from" "The index of a vertex" } { "from" "The index of a vertex" }
{ "to" "The index of another vertex" } { "to" "The index of another vertex" }
{ "graph" "A graph" } } { "graph" "A graph" } }
{ $description "Adds a one-way edge to the graph, between from and to." { $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
$nl $nl
"If you want to add a two-way edge, use " { $link add-edge } " instead." } ; "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
HELP: add-edge HELP: add-edge
{ $values { $values
{ "m" "The index of a vertex" } { "u" "The index of a vertex" }
{ "n" "The index of another vertex" } { "v" "The index of another vertex" }
{ "graph" "A graph" } } { "graph" "A graph" } }
{ $description "Adds a two-way edge to the graph, between m and n." { $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
$nl $nl
"If you want to add a one-way edge, use " { $link add-edge* } " instead." } ; "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ; USING: kernel help.markup help.syntax ;
IN: lists IN: lists
@ -23,7 +23,7 @@ HELP: nil
{ $description "Returns a symbol representing the empty list" } ; { $description "Returns a symbol representing the empty list" } ;
HELP: nil? HELP: nil?
{ $values { "cons" "a cons object" } { "?" "a boolean" } } { $values { "object" object } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ; { $description "Return true if the cons object is the nil cons." } ;
HELP: list? ( object -- ? ) HELP: list? ( object -- ? )

View File

@ -2,22 +2,22 @@ USING: kernel math.blas.matrices math.blas.vectors parser
arrays prettyprint.backend sequences ; arrays prettyprint.backend sequences ;
IN: math.blas.syntax IN: math.blas.syntax
: svector{ ( accum -- accum ) : svector{
\ } [ >float-blas-vector ] parse-literal ; parsing \ } [ >float-blas-vector ] parse-literal ; parsing
: dvector{ ( accum -- accum ) : dvector{
\ } [ >double-blas-vector ] parse-literal ; parsing \ } [ >double-blas-vector ] parse-literal ; parsing
: cvector{ ( accum -- accum ) : cvector{
\ } [ >float-complex-blas-vector ] parse-literal ; parsing \ } [ >float-complex-blas-vector ] parse-literal ; parsing
: zvector{ ( accum -- accum ) : zvector{
\ } [ >double-complex-blas-vector ] parse-literal ; parsing \ } [ >double-complex-blas-vector ] parse-literal ; parsing
: smatrix{ ( accum -- accum ) : smatrix{
\ } [ >float-blas-matrix ] parse-literal ; parsing \ } [ >float-blas-matrix ] parse-literal ; parsing
: dmatrix{ ( accum -- accum ) : dmatrix{
\ } [ >double-blas-matrix ] parse-literal ; parsing \ } [ >double-blas-matrix ] parse-literal ; parsing
: cmatrix{ ( accum -- accum ) : cmatrix{
\ } [ >float-complex-blas-matrix ] parse-literal ; parsing \ } [ >float-complex-blas-matrix ] parse-literal ; parsing
: zmatrix{ ( accum -- accum ) : zmatrix{
\ } [ >double-complex-blas-matrix ] parse-literal ; parsing \ } [ >double-complex-blas-matrix ] parse-literal ; parsing
M: float-blas-vector pprint-delims drop \ svector{ \ } ; M: float-blas-vector pprint-delims drop \ svector{ \ } ;

View File

@ -1,8 +1,8 @@
USING: help.markup help.syntax math.functions ; USING: help.markup help.syntax math math.functions ;
IN: math.derivatives IN: math.derivatives
HELP: derivative ( x function -- m ) HELP: derivative ( x function -- m )
{ $values { "x" "a position on the function" } { "function" "a differentiable function" } } { $values { "x" "a position on the function" } { "function" "a differentiable function" } { "m" number } }
{ $description { $description
"Approximates the slope of the tangent line by using Ridders' " "Approximates the slope of the tangent line by using Ridders' "
"method of computing derivatives, from the chapter \"Accurate computation " "method of computing derivatives, from the chapter \"Accurate computation "
@ -10,8 +10,8 @@ HELP: derivative ( x function -- m )
} }
{ $examples { $examples
{ $example { $example
"USING: math.derivatives prettyprint ;" "USING: math math.derivatives prettyprint ;"
"[ sq ] 4 derivative ." "4 [ sq ] derivative >integer ."
"8" "8"
} }
{ $notes { $notes
@ -20,10 +20,10 @@ HELP: derivative ( x function -- m )
} }
} ; } ;
HELP: (derivative) ( x function h err -- m ) HELP: (derivative)
{ $values { $values
{ "x" "a position on the function" } { "x" "a position on the function" }
{ "function" "a differentiable function" } { "func" "a differentiable function" }
{ {
"h" "distance between the points of the first secant line used for " "h" "distance between the points of the first secant line used for "
"approximation of the tangent. This distance will be divided " "approximation of the tangent. This distance will be divided "
@ -41,6 +41,8 @@ HELP: (derivative) ( x function h err -- m )
"when the error multiplies by 2. See " { $link check-safe } " for " "when the error multiplies by 2. See " { $link check-safe } " for "
"the enforcing code." "the enforcing code."
} }
{ "ans" number }
{ "error" number }
} }
{ $description { $description
"Approximates the slope of the tangent line by using Ridders' " "Approximates the slope of the tangent line by using Ridders' "
@ -50,8 +52,8 @@ HELP: (derivative) ( x function h err -- m )
} }
{ $examples { $examples
{ $example { $example
"USING: math.derivatives prettyprint ;" "USING: math math.derivatives prettyprint ;"
"[ sq ] 4 derivative ." "4 [ sq ] derivative >integer ."
"8" "8"
} }
{ $notes { $notes
@ -60,7 +62,7 @@ HELP: (derivative) ( x function h err -- m )
} }
} ; } ;
HELP: derivative-func ( function -- der ) HELP: derivative-func
{ $values { "func" "a differentiable function" } { "der" "the derivative" } } { $values { "func" "a differentiable function" } { "der" "the derivative" } }
{ $description { $description
"Provides the derivative of the function. The implementation simply " "Provides the derivative of the function. The implementation simply "
@ -68,7 +70,7 @@ HELP: derivative-func ( function -- der )
} }
{ $examples { $examples
{ $example { $example
"USING: math.derivatives prettyprint ;" "USING: kernel math.derivatives math.functions math.trig prettyprint ;"
"60 deg>rad [ sin ] derivative-func call ." "60 deg>rad [ sin ] derivative-func call ."
"0.5000000000000173" "0.5000000000000173"
} }

View File

@ -13,15 +13,26 @@ SYM: date properties adjoin
SYM: participants properties adjoin SYM: participants properties adjoin
SYM: description properties adjoin SYM: description properties adjoin
SYM: chapter properties adjoin
SYM: section properties adjoin
SYM: paragraph properties adjoin
SYM: content properties adjoin
SYM: subjects properties adjoin
SYM: source properties adjoin
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYM: paper types adjoin SYM: paper types adjoin
SYM: person types adjoin SYM: person types adjoin
SYM: event types adjoin SYM: event types adjoin
SYM: excerpt types adjoin
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYM: bay-wei-chang { type person } define-object SYM: bay-wei-chang { type person } define-object
SYM: chuck-moore { type person } define-object
SYM: craig-chambers { type person } define-object SYM: craig-chambers { type person } define-object
SYM: david-ungar { type person } define-object SYM: david-ungar { type person } define-object
SYM: frank-g-halasz { type person } define-object SYM: frank-g-halasz { type person } define-object
@ -121,10 +132,47 @@ define-object
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYM: the-evolution-of-forth
{
type paper
title "The Evolution of Forth"
authors { chuck-moore "elizabeth-d-rather" "donald-r-colburn" }
abstract
"Forth is unique among programming languages in that its development and proliferation has been a grass-roots effort unsupported by any major corporate or academic sponsors. Originally conceived and developed by a single individual, its later development has progressed under two significant influences: professional programmers who developed tools to solve application problems and then commercialized them, and the interests of hobbyists concerned with free distribution of Forth. These influences have produced a language markedly different from traditional programming languages."
date 1993
}
define-object
SYM: first-complete-stand-alone-forth
{
type event
participants { chuck-moore }
date 1971
}
define-object
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYM: notecards-in-a-nutshell SYM: notecards-in-a-nutshell
{ {
type paper type paper
authors { frank-g-halasz thomas-p-moran randall-h-trigg } authors { frank-g-halasz thomas-p-moran randall-h-trigg }
date 1987 date 1987
} }
define-object define-object
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYM: the-evolution-of-forth-excerpt-2-1-1
{
type excerpt
source the-evolution-of-forth
chapter 2
section 1
paragraph 1
content
"Moore developed the first complete, stand-alone implementation of Forth in 1971 for the 11-meter radio telescope operated by the National Radio Astronomy Observatory (NRAO) at Kitt Peak, Arizona. This system ran on two early minicomputers (a 16 KB DDP-116 and a 32 KB H316) joined by a serial link. Both a multiprogrammed system and a multiprocessor system (in that both computers shared responsibility for controlling the telescope and its scientific instruments), it was responsible for pointing and tracking the telescope, collecting data and recording it on magnetic tape, and supporting an interactive graphics terminal on which an astronomer could analyze previously recorded data. The multiprogrammed nature of the system allowed all these functions to be performed concurrently, without timing conflicts or other interference."
subjects { chuck-moore first-complete-stand-alone-forth }
}
define-object

View File

@ -110,7 +110,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
: input-from ( input -- n ) : input-from ( input -- n )
#! Return the index from the original string that the #! Return the index from the original string that the
#! input slice is based on. #! input slice is based on.
dup slice? [ slice-from ] [ drop 0 ] if ; dup slice? [ from>> ] [ drop 0 ] if ;
: process-rule-result ( p result -- result ) : process-rule-result ( p result -- result )
[ [

View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup kernel prettyprint sequences ; USING: help.syntax help.markup kernel prettyprint sequences
quotations words strings ;
IN: wordtimer IN: wordtimer
HELP: reset-word-timer HELP: reset-word-timer
@ -6,18 +7,18 @@ HELP: reset-word-timer
} ; } ;
HELP: add-timer HELP: add-timer
{ $values { "word" "a word" } } { $values { "word" word } }
{ $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings" { $description "annotates the word with timing code which stores timing information globally. You can then view the info with print-word-timings"
} ; } ;
HELP: add-timers HELP: add-timers
{ $values { "vocab" "a string" } } { $values { "vocab" string } }
{ $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab" { $description "annotates all the words in the vocab with timer code. After profiling you can remove the annotations with reset-vocab"
} ; } ;
HELP: reset-vocab HELP: reset-vocab
{ $values { "vocab" "a string" } } { $values { "vocab" string } }
{ $description "removes the annotations from all the words in the vocab" { $description "removes the annotations from all the words in the vocab"
} ; } ;
@ -29,13 +30,13 @@ HELP: correct-for-timing-overhead
{ $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ; { $description "attempts to correct the timings to take into account the overhead of the timing function. This is pretty error-prone but can be handy when you're timing words that only take a handful of milliseconds but are called a lot" } ;
HELP: profile-vocab HELP: profile-vocab
{ $values { "vocabspec" "string name of a vocab" } { $values { "vocab" string }
{ "quot" "a quotation to run" } } { "quot" "a quotation to run" } }
{ $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information." { $description "Annotates the words in the vocab with timing code then runs the quotation. Finally resets the words and prints the timings information."
} ; } ;
HELP: wordtimer-call HELP: wordtimer-call
{ $values { "quot" "a quotation to run" } } { $values { "quot" quotation } }
{ $description "Resets the wordtimer hash and runs the quotation. After the quotation has run it prints out the timed words" { $description "Resets the wordtimer hash and runs the quotation. After the quotation has run it prints out the timed words"
} ; } ;

View File

@ -40,10 +40,10 @@ SYMBOL: *calling*
: add-timer ( word -- ) : add-timer ( word -- )
dup [ (add-timer) ] annotate ; dup [ (add-timer) ] annotate ;
: add-timers ( vocabspec -- ) : add-timers ( vocab -- )
words [ add-timer ] each ; words [ add-timer ] each ;
: reset-vocab ( vocabspec -- ) : reset-vocab ( vocab -- )
words [ reset ] each ; words [ reset ] each ;
: dummy-word ( -- ) ; : dummy-word ( -- ) ;
@ -74,7 +74,7 @@ SYMBOL: *calling*
"total time:" write r> pprint nl "total time:" write r> pprint nl
print-word-timings nl ; print-word-timings nl ;
: profile-vocab ( vocabspec quot -- ) : profile-vocab ( vocab quot -- )
"annotating vocab..." print flush "annotating vocab..." print flush
over [ reset-vocab ] [ add-timers ] bi over [ reset-vocab ] [ add-timers ] bi
reset-word-timer reset-word-timer
@ -84,4 +84,4 @@ SYMBOL: *calling*
reset-vocab reset-vocab
correct-for-timing-overhead correct-for-timing-overhead
"total time:" write r> pprint "total time:" write r> pprint
print-word-timings ; print-word-timings ;