Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
b93baaa315
|
|
@ -174,7 +174,7 @@ threads sequences calendar accessors ;
|
|||
] ;
|
||||
|
||||
[ lock-timeout-test ] [
|
||||
linked-error-thread name>> "Lock timeout-er" =
|
||||
thread>> name>> "Lock timeout-er" =
|
||||
] must-fail-with
|
||||
|
||||
:: read/write-test ( -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: deques dlists kernel threads continuations math
|
||||
concurrency.conditions ;
|
||||
concurrency.conditions combinators.short-circuit accessors ;
|
||||
IN: concurrency.locks
|
||||
|
||||
! Simple critical sections
|
||||
|
|
@ -16,13 +16,13 @@ TUPLE: lock threads owner reentrant? ;
|
|||
<PRIVATE
|
||||
|
||||
: acquire-lock ( lock timeout -- )
|
||||
over lock-owner
|
||||
[ 2dup >r lock-threads r> "lock" wait ] when drop
|
||||
self swap set-lock-owner ;
|
||||
over owner>>
|
||||
[ 2dup >r threads>> r> "lock" wait ] when drop
|
||||
self >>owner drop ;
|
||||
|
||||
: release-lock ( lock -- )
|
||||
f over set-lock-owner
|
||||
lock-threads notify-1 ;
|
||||
f >>owner
|
||||
threads>> notify-1 ;
|
||||
|
||||
: do-lock ( lock timeout quot acquire release -- )
|
||||
>r >r pick rot r> call ! use up timeout acquire
|
||||
|
|
@ -34,8 +34,8 @@ TUPLE: lock threads owner reentrant? ;
|
|||
PRIVATE>
|
||||
|
||||
: with-lock-timeout ( lock timeout quot -- )
|
||||
pick lock-reentrant? [
|
||||
pick lock-owner self eq? [
|
||||
pick reentrant?>> [
|
||||
pick owner>> self eq? [
|
||||
2nip call
|
||||
] [
|
||||
(with-lock)
|
||||
|
|
@ -56,44 +56,43 @@ TUPLE: rw-lock readers writers reader# writer ;
|
|||
<PRIVATE
|
||||
|
||||
: add-reader ( lock -- )
|
||||
dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
|
||||
[ 1+ ] change-reader# drop ;
|
||||
|
||||
: acquire-read-lock ( lock timeout -- )
|
||||
over rw-lock-writer
|
||||
[ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
|
||||
over writer>>
|
||||
[ 2dup >r readers>> r> "read lock" wait ] when drop
|
||||
add-reader ;
|
||||
|
||||
: notify-writer ( lock -- )
|
||||
rw-lock-writers notify-1 ;
|
||||
writers>> notify-1 ;
|
||||
|
||||
: remove-reader ( lock -- )
|
||||
dup rw-lock-reader# 1- swap set-rw-lock-reader# ;
|
||||
[ 1- ] change-reader# drop ;
|
||||
|
||||
: release-read-lock ( lock -- )
|
||||
dup remove-reader
|
||||
dup rw-lock-reader# zero? [ notify-writer ] [ drop ] if ;
|
||||
dup reader#>> zero? [ notify-writer ] [ drop ] if ;
|
||||
|
||||
: acquire-write-lock ( lock timeout -- )
|
||||
over rw-lock-writer pick rw-lock-reader# 0 > or
|
||||
[ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
|
||||
self swap set-rw-lock-writer ;
|
||||
over writer>> pick reader#>> 0 > or
|
||||
[ 2dup >r writers>> r> "write lock" wait ] when drop
|
||||
self >>writer drop ;
|
||||
|
||||
: release-write-lock ( lock -- )
|
||||
f over set-rw-lock-writer
|
||||
dup rw-lock-readers deque-empty?
|
||||
[ notify-writer ] [ rw-lock-readers notify-all ] if ;
|
||||
f >>writer
|
||||
dup readers>> deque-empty?
|
||||
[ notify-writer ] [ readers>> notify-all ] if ;
|
||||
|
||||
: reentrant-read-lock-ok? ( lock -- ? )
|
||||
#! If we already have a write lock, then we can grab a read
|
||||
#! lock too.
|
||||
rw-lock-writer self eq? ;
|
||||
writer>> self eq? ;
|
||||
|
||||
: reentrant-write-lock-ok? ( lock -- ? )
|
||||
#! The only case where we have a writer and > 1 reader is
|
||||
#! write -> read re-entrancy, and in this case we prohibit
|
||||
#! a further write -> read -> write re-entrancy.
|
||||
dup rw-lock-writer self eq?
|
||||
swap rw-lock-reader# zero? and ;
|
||||
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ match quotations concurrency.messaging concurrency.mailboxes
|
|||
concurrency.count-downs accessors ;
|
||||
IN: concurrency.messaging.tests
|
||||
|
||||
[ ] [ my-mailbox mailbox-data clear-deque ] unit-test
|
||||
[ ] [ my-mailbox data>> clear-deque ] unit-test
|
||||
|
||||
[ "received" ] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2007 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces parser lexer kernel sequences words quotations math ;
|
||||
USING: namespaces parser lexer kernel sequences words quotations math
|
||||
accessors ;
|
||||
IN: multiline
|
||||
|
||||
: next-line-text ( -- str )
|
||||
lexer get dup next-line lexer-line-text ;
|
||||
lexer get dup next-line text>> ;
|
||||
|
||||
: (parse-here) ( -- )
|
||||
next-line-text [
|
||||
|
|
@ -22,7 +23,7 @@ IN: multiline
|
|||
parse-here 1quotation define-inline ; parsing
|
||||
|
||||
: (parse-multiline-string) ( start-index end-text -- end-index )
|
||||
lexer get lexer-line-text [
|
||||
lexer get text>> [
|
||||
2dup start
|
||||
[ rot dupd >r >r swap subseq % r> r> length + ] [
|
||||
rot tail % "\n" % 0
|
||||
|
|
@ -32,8 +33,8 @@ IN: multiline
|
|||
|
||||
: parse-multiline-string ( end-text -- str )
|
||||
[
|
||||
lexer get lexer-column swap (parse-multiline-string)
|
||||
lexer get set-lexer-column
|
||||
lexer get column>> swap (parse-multiline-string)
|
||||
lexer get (>>column)
|
||||
] "" make rest but-last ;
|
||||
|
||||
: <"
|
||||
|
|
|
|||
|
|
@ -195,11 +195,11 @@ DEFER: parse-error-file
|
|||
|
||||
: string-layout
|
||||
{
|
||||
"USING: debugger io kernel lexer ;"
|
||||
"USING: accessors debugger io kernel ;"
|
||||
"IN: prettyprint.tests"
|
||||
": string-layout-test ( error -- )"
|
||||
" \"Expected \" write dup unexpected-want expected>string write"
|
||||
" \" but got \" write unexpected-got expected>string print ;"
|
||||
" \"Expected \" write dup want>> expected>string write"
|
||||
" \" but got \" write got>> expected>string print ;"
|
||||
} ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -115,10 +115,10 @@ M: object short-section? section-fits? ;
|
|||
|
||||
: pprint-section ( section -- )
|
||||
dup short-section? [
|
||||
dup section-style [ short-section ] with-style
|
||||
dup style>> [ short-section ] with-style
|
||||
] [
|
||||
[ <long-section ]
|
||||
[ dup section-style [ long-section ] with-style ]
|
||||
[ dup style>> [ long-section ] with-style ]
|
||||
[ long-section> ]
|
||||
tri
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@ ui.render ;
|
|||
IN: ui.gadgets.grid-lines
|
||||
|
||||
HELP: grid-lines
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math namespaces opengl opengl.gl sequences
|
||||
USING: kernel accessors math namespaces opengl opengl.gl sequences
|
||||
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||
IN: ui.gadgets.grid-lines
|
||||
|
||||
|
|
@ -10,7 +10,7 @@ C: <grid-lines> grid-lines
|
|||
|
||||
SYMBOL: grid-dim
|
||||
|
||||
: half-gap grid get grid-gap [ 2/ ] map ; inline
|
||||
: half-gap grid get gap>> [ 2/ ] map ; inline
|
||||
|
||||
: grid-line-from/to ( orientation point -- from to )
|
||||
half-gap v-
|
||||
|
|
@ -25,7 +25,7 @@ SYMBOL: grid-dim
|
|||
M: grid-lines draw-boundary
|
||||
origin get [
|
||||
-0.5 -0.5 0.0 glTranslated
|
||||
grid-lines-color set-color [
|
||||
color>> set-color [
|
||||
dup grid set
|
||||
dup rect-dim half-gap v- grid-dim set
|
||||
compute-grid
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@ ARTICLE: "ui-grid-layout" "Grid layouts"
|
|||
HELP: grid
|
||||
{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
|
||||
$nl
|
||||
"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
|
||||
"The " { $snippet "gap" } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
|
||||
$nl
|
||||
"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
||||
"The " { $snippet "fill?" } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
|
||||
$nl
|
||||
"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ grid
|
|||
dupd add-gaps dim-sum v+ ;
|
||||
|
||||
M: grid pref-dim*
|
||||
dup grid-gap swap compute-grid >r over r>
|
||||
dup gap>> swap compute-grid >r over r>
|
||||
gap-sum >r gap-sum r> (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
|
|
@ -57,7 +57,7 @@ M: grid pref-dim*
|
|||
drop ; inline
|
||||
|
||||
: grid-positions ( grid dims -- locs )
|
||||
>r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
|
||||
>r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
|
||||
|
||||
: position-grid ( grid horiz vert -- )
|
||||
pick >r
|
||||
|
|
@ -65,7 +65,7 @@ M: grid pref-dim*
|
|||
pair-up r> [ set-rect-loc ] do-grid ;
|
||||
|
||||
: resize-grid ( grid horiz vert -- )
|
||||
pick grid-fill? [
|
||||
pick fill?>> [
|
||||
pair-up swap [ (>>dim) ] do-grid
|
||||
] [
|
||||
2drop grid>> [ [ prefer ] each ] each
|
||||
|
|
|
|||
|
|
@ -24,20 +24,20 @@ TUPLE: incremental < pack cursor ;
|
|||
|
||||
M: incremental pref-dim*
|
||||
dup layout-state>> [
|
||||
dup call-next-method over set-incremental-cursor
|
||||
] when incremental-cursor ;
|
||||
dup call-next-method over (>>cursor)
|
||||
] when cursor>> ;
|
||||
|
||||
: next-cursor ( gadget incremental -- cursor )
|
||||
[
|
||||
swap rect-dim swap incremental-cursor
|
||||
swap rect-dim swap cursor>>
|
||||
2dup v+ >r vmax r>
|
||||
] keep orientation>> set-axis ;
|
||||
|
||||
: update-cursor ( gadget incremental -- )
|
||||
[ next-cursor ] keep set-incremental-cursor ;
|
||||
[ next-cursor ] keep (>>cursor) ;
|
||||
|
||||
: incremental-loc ( gadget incremental -- )
|
||||
dup incremental-cursor swap orientation>> v*
|
||||
dup cursor>> swap orientation>> v*
|
||||
swap set-rect-loc ;
|
||||
|
||||
: prefer-incremental ( gadget -- )
|
||||
|
|
@ -57,5 +57,5 @@ M: incremental pref-dim*
|
|||
not-in-layout
|
||||
dup (clear-gadget)
|
||||
dup forget-pref-dim
|
||||
{ 0 0 } over set-incremental-cursor
|
||||
{ 0 0 } over (>>cursor)
|
||||
parent>> [ relayout ] when* ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ TUPLE: labelled-gadget < track content ;
|
|||
swap >>content
|
||||
dup content>> 1 track-add ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
M: labelled-gadget focusable-child* content>> ;
|
||||
|
||||
: <labelled-scroller> ( gadget title -- gadget )
|
||||
>r <scroller> r> <labelled-gadget> ;
|
||||
|
|
@ -53,4 +53,4 @@ TUPLE: closable-gadget < frame content ;
|
|||
swap >>content
|
||||
dup content>> @center grid-add ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
M: closable-gadget focusable-child* content>> ;
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@ TUPLE: label < gadget text font color ;
|
|||
|
||||
: set-label-string ( string label -- )
|
||||
CHAR: \n pick memq? [
|
||||
>r string-lines r> set-label-text
|
||||
>r string-lines r> (>>text)
|
||||
] [
|
||||
set-label-text
|
||||
(>>text)
|
||||
] if ; inline
|
||||
|
||||
: label-theme ( gadget -- gadget )
|
||||
|
|
|
|||
|
|
@ -27,8 +27,8 @@ TUPLE: list < pack index presenter color hook ;
|
|||
control-value length 1- min 0 max ;
|
||||
|
||||
: bound-index ( list -- )
|
||||
dup list-index over calc-bounded-index
|
||||
swap set-list-index ;
|
||||
dup index>> over calc-bounded-index
|
||||
swap (>>index) ;
|
||||
|
||||
: list-presentation-hook ( list -- quot )
|
||||
hook>> [ [ list? ] find-parent ] prepend ;
|
||||
|
|
@ -53,18 +53,18 @@ M: list model-changed
|
|||
bound-index ;
|
||||
|
||||
: selected-rect ( list -- rect )
|
||||
dup list-index swap children>> ?nth ;
|
||||
dup index>> swap children>> ?nth ;
|
||||
|
||||
M: list draw-gadget*
|
||||
origin get [
|
||||
dup list-color set-color
|
||||
dup color>> set-color
|
||||
selected-rect [ rect-extent gl-fill-rect ] when*
|
||||
] with-translation ;
|
||||
|
||||
M: list focusable-child* drop t ;
|
||||
|
||||
: list-value ( list -- object )
|
||||
dup list-index swap control-value ?nth ;
|
||||
dup index>> swap control-value ?nth ;
|
||||
|
||||
: scroll>selected ( list -- )
|
||||
#! We change the rectangle's width to zero to avoid
|
||||
|
|
@ -79,22 +79,22 @@ M: list focusable-child* drop t ;
|
|||
2drop
|
||||
] [
|
||||
[ control-value length rem ] keep
|
||||
[ set-list-index ] keep
|
||||
[ (>>index) ] keep
|
||||
[ relayout-1 ] keep
|
||||
scroll>selected
|
||||
] if ;
|
||||
|
||||
: select-previous ( list -- )
|
||||
dup list-index 1- swap select-index ;
|
||||
dup index>> 1- swap select-index ;
|
||||
|
||||
: select-next ( list -- )
|
||||
dup list-index 1+ swap select-index ;
|
||||
dup index>> 1+ swap select-index ;
|
||||
|
||||
: invoke-value-action ( list -- )
|
||||
dup list-empty? [
|
||||
dup list-hook call
|
||||
dup hook>> call
|
||||
] [
|
||||
dup list-index swap nth-gadget invoke-secondary
|
||||
dup index>> swap nth-gadget invoke-secondary
|
||||
] if ;
|
||||
|
||||
: select-gadget ( gadget list -- )
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@ M: pane-stream make-span-stream
|
|||
>r pick at r> when* ; inline
|
||||
|
||||
: apply-foreground-style ( style gadget -- style gadget )
|
||||
foreground [ over set-label-color ] apply-style ;
|
||||
foreground [ over (>>color) ] apply-style ;
|
||||
|
||||
: apply-background-style ( style gadget -- style gadget )
|
||||
background [ solid-interior ] apply-style ;
|
||||
|
|
@ -184,7 +184,7 @@ M: pane-stream make-span-stream
|
|||
font-size swap at 12 or 3array ;
|
||||
|
||||
: apply-font-style ( style gadget -- style gadget )
|
||||
over specified-font over set-label-font ;
|
||||
over specified-font over (>>font) ;
|
||||
|
||||
: apply-presentation-style ( style gadget -- style gadget )
|
||||
presented [ <presentation> ] apply-style ;
|
||||
|
|
@ -255,7 +255,7 @@ M: pane-stream make-block-stream
|
|||
|
||||
! Tables
|
||||
: apply-table-gap-style ( style grid -- style grid )
|
||||
table-gap [ over set-grid-gap ] apply-style ;
|
||||
table-gap [ over (>>gap) ] apply-style ;
|
||||
|
||||
: apply-table-border-style ( style grid -- style grid )
|
||||
table-border [ <grid-lines> over (>>boundary) ]
|
||||
|
|
@ -263,7 +263,7 @@ M: pane-stream make-block-stream
|
|||
|
||||
: styled-grid ( style grid -- grid )
|
||||
<grid>
|
||||
f over set-grid-fill?
|
||||
f over (>>fill?)
|
||||
apply-table-gap-style
|
||||
apply-table-border-style
|
||||
nip ;
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
|
|||
[ dimensions 2array ] bi@ =
|
||||
[ dimensions-not-equal ] unless ;
|
||||
|
||||
: 2values ( dim dim -- val val ) [ dimensioned-value ] bi@ ;
|
||||
: 2values ( dim dim -- val val ) [ value>> ] bi@ ;
|
||||
|
||||
: <dimension-op ( dim dim -- top bot val val )
|
||||
2dup check-dimensions dup dimensions 2swap 2values ;
|
||||
|
|
@ -56,8 +56,8 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
|
|||
|
||||
: d* ( d d -- d )
|
||||
[ dup number? [ scalar ] when ] bi@
|
||||
[ [ dimensioned-top ] bi@ append ] 2keep
|
||||
[ [ dimensioned-bot ] bi@ append ] 2keep
|
||||
[ [ top>> ] bi@ append ] 2keep
|
||||
[ [ bot>> ] bi@ append ] 2keep
|
||||
2values * dimension-op> ;
|
||||
|
||||
: d-neg ( d -- d ) -1 d* ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros sequences slots words classes.tuple
|
||||
quotations combinators ;
|
||||
quotations combinators accessors ;
|
||||
IN: classes.tuple.lib
|
||||
|
||||
: reader-slots ( seq -- quot )
|
||||
[ slot-spec-reader 1quotation ] map [ cleave ] curry ;
|
||||
[ reader>> 1quotation ] map [ cleave ] curry ;
|
||||
|
||||
MACRO: >tuple< ( class -- )
|
||||
all-slots rest-slice reader-slots ;
|
||||
|
|
|
|||
|
|
@ -353,11 +353,11 @@ M: quotation fjsc-parse ( object -- ast )
|
|||
] with-string-writer ;
|
||||
|
||||
: fjsc-compile* ( string -- string )
|
||||
'statement' parse parse-result-ast fjsc-compile ;
|
||||
'statement' parse ast>> fjsc-compile ;
|
||||
|
||||
: fc* ( string -- string )
|
||||
[
|
||||
'statement' parse parse-result-ast values>> do-expressions
|
||||
'statement' parse ast>> values>> do-expressions
|
||||
] { } make [ write ] each ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -208,7 +208,7 @@ DEFER: _
|
|||
|
||||
: slot-readers ( class -- quot )
|
||||
all-slots rest ! tail gets rid of delegate
|
||||
[ slot-spec-reader 1quotation [ keep ] curry ] map concat
|
||||
[ reader>> 1quotation [ keep ] curry ] map concat
|
||||
[ ] like [ drop ] compose ;
|
||||
|
||||
: ?wrapped ( object -- wrapped )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser-combinators namespaces sequences promises strings
|
||||
assocs math math.parser math.vectors math.functions math.order
|
||||
lists hashtables ascii ;
|
||||
lists hashtables ascii accessors ;
|
||||
IN: json.reader
|
||||
|
||||
! Grammar for JSON from RFC 4627
|
||||
|
|
@ -169,11 +169,12 @@ LAZY: 'value' ( -- parser )
|
|||
'array' ,
|
||||
'number' ,
|
||||
] [<|>] spaced ;
|
||||
ERROR: could-not-parse-json ;
|
||||
|
||||
: json> ( string -- object )
|
||||
#! Parse a json formatted string to a factor object
|
||||
'value' parse dup nil? [
|
||||
"Could not parse json" throw
|
||||
could-not-parse-json
|
||||
] [
|
||||
car parse-result-parsed
|
||||
car parsed>>
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: lazy-cons car cdr ;
|
|||
: lazy-cons ( car cdr -- promise )
|
||||
[ promise ] bi@ \ lazy-cons boa
|
||||
T{ promise f f t f } clone
|
||||
[ set-promise-value ] keep ;
|
||||
swap >>value ;
|
||||
|
||||
M: lazy-cons car ( lazy-cons -- car )
|
||||
car>> force ;
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ LAZY: 'morse-words' ( -- parser )
|
|||
PRIVATE>
|
||||
|
||||
: morse> ( str -- str )
|
||||
'morse-words' parse car parse-result-parsed [
|
||||
'morse-words' parse car parsed>> [
|
||||
[
|
||||
>string morse>ch
|
||||
] map >string
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
||||
ui.gadgets ui.render threads ;
|
||||
ui.gadgets ui.render threads accessors ;
|
||||
IN: nehe.4
|
||||
|
||||
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
|
||||
|
|
@ -10,8 +10,8 @@ TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
|
|||
|
||||
: <nehe4-gadget> ( -- gadget )
|
||||
nehe4-gadget new-gadget
|
||||
0.0 over set-nehe4-gadget-rtri
|
||||
0.0 over set-nehe4-gadget-rquad ;
|
||||
0.0 >>rtri
|
||||
0.0 >>rquad ;
|
||||
|
||||
M: nehe4-gadget pref-dim* ( gadget -- dim )
|
||||
drop width height 2array ;
|
||||
|
|
@ -53,22 +53,22 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
|
|||
1.0 -1.0 0.0 glVertex3f
|
||||
-1.0 -1.0 0.0 glVertex3f
|
||||
] do-state
|
||||
dup nehe4-gadget-rtri 0.2 + over set-nehe4-gadget-rtri
|
||||
dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
|
||||
[ 0.2 + ] change-rtri
|
||||
[ 0.15 - ] change-rquad drop ;
|
||||
|
||||
: nehe4-update-thread ( gadget -- )
|
||||
dup nehe4-gadget-quit? [ drop ] [
|
||||
dup quit?>> [ drop ] [
|
||||
redraw-interval sleep
|
||||
dup relayout-1
|
||||
nehe4-update-thread
|
||||
] if ;
|
||||
|
||||
M: nehe4-gadget graft* ( gadget -- )
|
||||
[ f swap set-nehe4-gadget-quit? ] keep
|
||||
f >>quit?
|
||||
[ nehe4-update-thread ] in-thread drop ;
|
||||
|
||||
M: nehe4-gadget ungraft* ( gadget -- )
|
||||
t swap set-nehe4-gadget-quit? ;
|
||||
t >>quit? drop ;
|
||||
|
||||
: run4 ( -- )
|
||||
<nehe4-gadget> "NeHe Tutorial 4" open-window ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: arrays kernel math opengl opengl.gl opengl.glu ui
|
||||
ui.gadgets ui.render threads ;
|
||||
ui.gadgets ui.render threads accessors ;
|
||||
IN: nehe.5
|
||||
|
||||
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
|
||||
|
|
@ -9,8 +9,8 @@ TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
|
|||
|
||||
: <nehe5-gadget> ( -- gadget )
|
||||
nehe5-gadget new-gadget
|
||||
0.0 over set-nehe5-gadget-rtri
|
||||
0.0 over set-nehe5-gadget-rquad ;
|
||||
0.0 >>rtri
|
||||
0.0 >>rquad ;
|
||||
|
||||
M: nehe5-gadget pref-dim* ( gadget -- dim )
|
||||
drop width height 2array ;
|
||||
|
|
@ -103,11 +103,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
|
|||
1.0 -1.0 1.0 glVertex3f
|
||||
1.0 -1.0 -1.0 glVertex3f
|
||||
] do-state
|
||||
dup nehe5-gadget-rtri 0.2 + over set-nehe5-gadget-rtri
|
||||
dup nehe5-gadget-rquad 0.15 - swap set-nehe5-gadget-rquad ;
|
||||
[ 0.2 + ] change-rtri
|
||||
[ 0.15 - ] change-rquad drop ;
|
||||
|
||||
: nehe5-update-thread ( gadget -- )
|
||||
dup nehe5-gadget-quit? [
|
||||
dup quit?>> [
|
||||
drop
|
||||
] [
|
||||
redraw-interval sleep
|
||||
|
|
@ -116,11 +116,11 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
|
|||
] if ;
|
||||
|
||||
M: nehe5-gadget graft* ( gadget -- )
|
||||
[ f swap set-nehe5-gadget-quit? ] keep
|
||||
[ nehe5-update-thread ] in-thread drop ;
|
||||
f >>quit?
|
||||
[ nehe5-update-thread ] in-thread drop ;
|
||||
|
||||
M: nehe5-gadget ungraft* ( gadget -- )
|
||||
t swap set-nehe5-gadget-quit? ;
|
||||
t >>quit? drop ;
|
||||
|
||||
|
||||
: run5 ( -- )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: kernel namespaces
|
||||
USING: kernel namespaces accessors
|
||||
math math.constants math.functions math.matrices math.vectors
|
||||
sequences splitting grouping self math.trig ;
|
||||
|
||||
|
|
@ -11,9 +11,9 @@ C: <ori> ori
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: ori> ( -- val ) self> ori-val ;
|
||||
: ori> ( -- val ) self> val>> ;
|
||||
|
||||
: >ori ( val -- ) self> set-ori-val ;
|
||||
: >ori ( val -- ) self> (>>val) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lists lists.lazy promises kernel sequences strings math
|
||||
arrays splitting quotations combinators namespaces
|
||||
unicode.case unicode.categories sequences.deep ;
|
||||
unicode.case unicode.categories sequences.deep accessors ;
|
||||
IN: parser-combinators
|
||||
|
||||
! Parser combinator protocol
|
||||
|
|
@ -13,11 +13,13 @@ M: promise parse ( input parser -- list )
|
|||
|
||||
TUPLE: parse-result parsed unparsed ;
|
||||
|
||||
ERROR: cannot-parse input ;
|
||||
|
||||
: parse-1 ( input parser -- result )
|
||||
dupd parse dup nil? [
|
||||
"Cannot parse " rot append throw
|
||||
rot cannot-parse
|
||||
] [
|
||||
nip car parse-result-parsed
|
||||
nip car parsed>>
|
||||
] if ;
|
||||
|
||||
C: <parse-result> parse-result
|
||||
|
|
@ -26,12 +28,12 @@ C: <parse-result> parse-result
|
|||
<parse-result> 1list ;
|
||||
|
||||
: parse-result-parsed-slice ( parse-result -- slice )
|
||||
dup parse-result-parsed empty? [
|
||||
parse-result-unparsed 0 0 rot <slice>
|
||||
dup parsed>> empty? [
|
||||
unparsed>> 0 0 rot <slice>
|
||||
] [
|
||||
dup parse-result-unparsed
|
||||
dup slice-from [ rot parse-result-parsed length - ] keep
|
||||
rot slice-seq <slice>
|
||||
dup unparsed>>
|
||||
dup from>> [ rot parsed>> length - ] keep
|
||||
rot seq>> <slice>
|
||||
] if ;
|
||||
|
||||
: string= ( str1 str2 ignore-case -- ? )
|
||||
|
|
@ -132,7 +134,7 @@ TUPLE: and-parser parsers ;
|
|||
|
||||
: <&> ( parser1 parser2 -- parser )
|
||||
over and-parser? [
|
||||
>r and-parser-parsers r> suffix
|
||||
>r parsers>> r> suffix
|
||||
] [
|
||||
2array
|
||||
] if and-parser boa ;
|
||||
|
|
@ -142,11 +144,11 @@ TUPLE: and-parser parsers ;
|
|||
|
||||
: and-parser-parse ( list p1 -- list )
|
||||
swap [
|
||||
dup parse-result-unparsed rot parse
|
||||
dup unparsed>> rot parse
|
||||
[
|
||||
>r parse-result-parsed r>
|
||||
[ parse-result-parsed 2array ] keep
|
||||
parse-result-unparsed <parse-result>
|
||||
>r parsed>> r>
|
||||
[ parsed>> 2array ] keep
|
||||
unparsed>> <parse-result>
|
||||
] lazy-map-with
|
||||
] lazy-map-with lconcat ;
|
||||
|
||||
|
|
|
|||
|
|
@ -508,10 +508,10 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
|
|||
|
||||
: check-parse-result ( result -- result )
|
||||
dup [
|
||||
dup parse-result-remaining [ blank? ] trim empty? [
|
||||
dup remaining>> [ blank? ] trim empty? [
|
||||
[
|
||||
"Unable to fully parse EBNF. Left to parse was: " %
|
||||
parse-result-remaining %
|
||||
remaining>> %
|
||||
] "" make throw
|
||||
] unless
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
|
||||
USING: kernel math math.functions math.vectors sequences self ;
|
||||
USING: kernel math math.functions math.vectors sequences self
|
||||
accessors ;
|
||||
|
||||
IN: pos
|
||||
|
||||
|
|
@ -9,13 +10,13 @@ TUPLE: pos val ;
|
|||
|
||||
C: <pos> pos
|
||||
|
||||
: pos> ( -- val ) self> pos-val ;
|
||||
: pos> ( -- val ) self> val>> ;
|
||||
|
||||
: >pos ( val -- ) self> set-pos-val ;
|
||||
: >pos ( val -- ) self> (>>val) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: distance ( pos pos -- n ) pos-val swap pos-val v- [ sq ] map sum sqrt ;
|
||||
: distance ( pos pos -- n ) val>> swap val>> v- [ sq ] map sum sqrt ;
|
||||
|
||||
: move-by ( point -- ) pos> v+ >pos ;
|
||||
|
||||
|
|
|
|||
|
|
@ -270,14 +270,14 @@ TUPLE: regexp source parser ignore-case? ;
|
|||
] keep regexp boa ;
|
||||
|
||||
: do-ignore-case ( string regexp -- string regexp )
|
||||
dup regexp-ignore-case? [ >r >upper r> ] when ;
|
||||
dup ignore-case?>> [ >r >upper r> ] when ;
|
||||
|
||||
: matches? ( string regexp -- ? )
|
||||
do-ignore-case regexp-parser just parse nil? not ;
|
||||
do-ignore-case parser>> just parse nil? not ;
|
||||
|
||||
: match-head ( string regexp -- end )
|
||||
do-ignore-case regexp-parser parse dup nil?
|
||||
[ drop f ] [ car parse-result-unparsed from>> ] if ;
|
||||
do-ignore-case parser>> parse dup nil?
|
||||
[ drop f ] [ car unparsed>> from>> ] if ;
|
||||
|
||||
! Literal syntax for regexps
|
||||
: parse-options ( string -- ? )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: kernel parser lexer strings math namespaces sequences words io
|
||||
arrays quotations debugger kernel.private sequences.private ;
|
||||
USING: kernel parser lexer strings math namespaces
|
||||
sequences words io arrays quotations debugger accessors
|
||||
sequences.private ;
|
||||
IN: state-machine
|
||||
|
||||
: STATES:
|
||||
|
|
@ -20,9 +21,9 @@ M: missing-state error.
|
|||
! quot is ( state string -- output-string )
|
||||
[ missing-state ] <array> dup
|
||||
[
|
||||
[ >r dup dup state-data swap state-place r> ] %
|
||||
[ >r dup [ data>> ] [ place>> ] bi r> ] %
|
||||
[ swapd bounds-check dispatch ] curry ,
|
||||
[ each pick set-state-place swap set-state-data ] %
|
||||
[ each pick (>>place) swap (>>date) ] %
|
||||
] [ ] make [ over make ] curry ;
|
||||
|
||||
: define-machine ( word state-class -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: turing
|
||||
USING: arrays assocs io kernel math namespaces
|
||||
prettyprint sequences strings vectors words ;
|
||||
prettyprint sequences strings vectors words accessors ;
|
||||
IN: turing
|
||||
|
||||
! A turing machine simulator.
|
||||
|
||||
|
|
@ -55,9 +55,9 @@ SYMBOL: tape
|
|||
: turing-step ( -- )
|
||||
#! Do one step of the turing machine.
|
||||
next-state
|
||||
dup state-sym set-sym
|
||||
dup state-dir position [ + ] change
|
||||
state-next state set ;
|
||||
dup sym>> set-sym
|
||||
dup dir>> position [ + ] change
|
||||
next>> state set ;
|
||||
|
||||
: c ( -- )
|
||||
#! Print current turing machine state.
|
||||
|
|
|
|||
Loading…
Reference in New Issue