Clean up some usages of tuck, and add Joe's curried cleave/spread/apply combinators to kernel vocabulary
Slava Pestov
parent
6cd835e567
commit
669548e62e
|
|
@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.fixnum
|
|||
ds-push ;
|
||||
|
||||
: emit-fixnum-comparison ( node cc -- )
|
||||
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
|
||||
[ ^^compare ] [ ^^compare-imm ] bi-curry
|
||||
emit-fixnum-op ;
|
||||
|
||||
: emit-bignum>fixnum ( -- )
|
||||
|
|
|
|||
|
|
@ -28,15 +28,14 @@ IN: compiler.cfg.intrinsics.slots
|
|||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: (emit-set-slot) ( infos -- obj-reg )
|
||||
[ 3inputs [ tuck ] dip ^^offset>slot ]
|
||||
[ second value-tag ]
|
||||
bi* ^^set-slot ;
|
||||
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
|
||||
pick [ ^^set-slot ] dip ;
|
||||
|
||||
: (emit-set-slot-imm) ( infos -- obj-reg )
|
||||
ds-drop
|
||||
[ 2inputs tuck ]
|
||||
[ 2inputs ]
|
||||
[ [ third literal>> ] [ second value-tag ] bi ] bi*
|
||||
##set-slot-imm ;
|
||||
pick [ ##set-slot-imm ] dip ;
|
||||
|
||||
: emit-set-slot ( node -- )
|
||||
dup node-input-infos
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@ SYMBOL: spill-counts
|
|||
#! If it has been spilled already, reuse spill location.
|
||||
over reload-from>>
|
||||
[ over vreg>> reg-class>> next-spill-location ] unless*
|
||||
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
|
||||
[ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
|
||||
|
||||
: split-and-spill ( new existing -- before after )
|
||||
dup rot start>> split-interval
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
] ;
|
||||
|
||||
: drop-dead-outputs ( node -- #shuffle )
|
||||
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] any? ;
|
||||
|
|
|
|||
|
|
@ -64,10 +64,9 @@ TUPLE: document < model locs undos redos inside-undo? ;
|
|||
] if ; inline
|
||||
|
||||
: start/end-on-line ( from to line# -- n1 n2 )
|
||||
tuck
|
||||
[ [ document get ] 2dip start-on-line ]
|
||||
[ [ document get ] 2dip end-on-line ]
|
||||
2bi* ;
|
||||
bi-curry bi* ;
|
||||
|
||||
: last-line# ( document -- line )
|
||||
value>> length 1- ;
|
||||
|
|
@ -101,7 +100,7 @@ CONSTANT: doc-start { 0 0 }
|
|||
[ first2 swap ] dip nth swap ;
|
||||
|
||||
: prepare-insert ( new-lines from to lines -- new-lines )
|
||||
tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
|
||||
[ loc-col/str head-slice ] [ loc-col/str tail-slice ] bi-curry bi*
|
||||
pick append-last over prepend-first ;
|
||||
|
||||
: (set-doc-range) ( doc-lines from to lines -- changed-lines )
|
||||
|
|
@ -162,7 +161,7 @@ PRIVATE>
|
|||
over first 0 < [
|
||||
2drop { 0 0 }
|
||||
] [
|
||||
[ first2 swap tuck ] dip validate-col 2array
|
||||
[ first2 over ] dip validate-col 2array
|
||||
] if
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -82,8 +82,8 @@ M: heap heap-size ( heap -- n )
|
|||
data>> first ; inline
|
||||
|
||||
: data-exchange ( m n heap -- )
|
||||
[ tuck data-nth [ data-nth ] dip ] 3keep
|
||||
tuck [ data-set-nth ] 2dip data-set-nth ; inline
|
||||
[ [ data-nth ] curry bi@ ]
|
||||
[ [ data-set-nth ] curry bi@ ] 3bi ; inline
|
||||
|
||||
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
|
||||
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ tags global [ H{ } clone or ] change-at
|
|||
XML-NS: chloe-name http://factorcode.org/chloe/1.0
|
||||
|
||||
: required-attr ( tag name -- value )
|
||||
tuck chloe-name attr
|
||||
[ nip ] [ " attribute is required" append throw ] if* ;
|
||||
[ nip ] [ chloe-name attr ] 2bi
|
||||
[ ] [ " attribute is required" append throw ] ?if ;
|
||||
|
||||
: optional-attr ( tag name -- value )
|
||||
chloe-name attr ;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ M: duplex-stream dispose
|
|||
] with-destructors ;
|
||||
|
||||
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
|
||||
tuck [ re-decode ] [ re-encode ] 2bi* <duplex-stream> ;
|
||||
[ re-decode ] [ re-encode ] bi-curry bi* <duplex-stream> ;
|
||||
|
||||
: with-stream* ( stream quot -- )
|
||||
[ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
|
|||
: complex/ ( x y -- r i m )
|
||||
[ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
|
||||
|
||||
M: complex / complex/ tuck [ / ] 2bi@ (rect>) ;
|
||||
M: complex / complex/ [ / ] curry bi@ (rect>) ;
|
||||
|
||||
M: complex abs absq >float fsqrt ;
|
||||
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ M: integer ^n
|
|||
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
|
||||
|
||||
M: ratio ^n
|
||||
[ >fraction ] dip tuck [ ^n ] 2bi@ / ;
|
||||
[ >fraction ] dip [ ^n ] curry bi@ / ;
|
||||
|
||||
M: float ^n
|
||||
(^n) ;
|
||||
|
|
|
|||
|
|
@ -104,10 +104,10 @@ M: word integer-op-input-classes
|
|||
|
||||
: define-integer-ops ( word fix-word big-word -- )
|
||||
[
|
||||
rot tuck
|
||||
rot
|
||||
[ fixnum fixnum 3array "derived-from" set-word-prop ]
|
||||
[ bignum bignum 3array "derived-from" set-word-prop ]
|
||||
2bi*
|
||||
bi-curry bi*
|
||||
] [
|
||||
[ integer-op-triples ] 2dip
|
||||
[ define-integer-op-words ]
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: integer /
|
|||
"Division by zero" throw
|
||||
] [
|
||||
dup 0 < [ [ neg ] bi@ ] when
|
||||
2dup gcd nip tuck [ /i ] 2bi@ fraction>
|
||||
2dup gcd nip [ /i ] curry bi@ fraction>
|
||||
] if ;
|
||||
|
||||
M: ratio hashcode*
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ IN: math.statistics
|
|||
|
||||
: minmax ( seq -- min max )
|
||||
#! find the min and max of a seq in one pass
|
||||
[ 1/0. -1/0. ] dip [ tuck [ min ] [ max ] 2bi* ] each ;
|
||||
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
|
||||
|
||||
: range ( seq -- n )
|
||||
minmax swap - ;
|
||||
|
|
|
|||
|
|
@ -15,12 +15,12 @@ GENERIC: random-32* ( tuple -- r )
|
|||
GENERIC: random-bytes* ( n tuple -- byte-array )
|
||||
|
||||
M: object random-bytes* ( n tuple -- byte-array )
|
||||
[ [ <byte-vector> ] keep 4 /mod ] dip tuck
|
||||
[ [ <byte-vector> ] keep 4 /mod ] dip
|
||||
[ pick '[ _ random-32* 4 >le _ push-all ] times ]
|
||||
[
|
||||
over zero?
|
||||
[ 2drop ] [ random-32* 4 >le swap head over push-all ] if
|
||||
] 2bi* ;
|
||||
] bi-curry bi* ;
|
||||
|
||||
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -65,9 +65,8 @@ IN: tools.completion
|
|||
[ second >lower swap complete ] keep 2array ;
|
||||
|
||||
: completions ( short candidates -- seq )
|
||||
[ '[ _ ] ]
|
||||
[ '[ >lower _ [ completion ] with map rank-completions ] ] bi
|
||||
if-empty ;
|
||||
[ ] [ [ >lower ] dip [ completion ] with map rank-completions ]
|
||||
bi-curry if-empty ;
|
||||
|
||||
: name-completions ( str seq -- seq' )
|
||||
[ dup name>> ] { } map>assoc completions ;
|
||||
|
|
|
|||
|
|
@ -52,9 +52,8 @@ IN: tools.memory
|
|||
} spread ;
|
||||
|
||||
: heap-stat-step ( obj counts sizes -- )
|
||||
[ over ] dip
|
||||
[ [ class ] dip inc-at ]
|
||||
[ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
|
||||
[ [ [ size ] [ class ] bi ] dip at+ ] bi-curry* bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: border baseline
|
|||
gadget-child pref-dim ;
|
||||
|
||||
: scale ( a b s -- c )
|
||||
tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
|
||||
[ v* ] [ { 1 1 } swap v- v* ] bi-curry bi* v+ ;
|
||||
|
||||
: border-dim ( border -- dim )
|
||||
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
|
||||
|
|
|
|||
|
|
@ -2,12 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays documents documents.elements kernel math
|
||||
models models.filter namespaces locals fry make opengl opengl.gl
|
||||
sequences strings math.vectors sorting colors combinators assocs
|
||||
math.order fry calendar alarms continuations ui.clipboards ui.commands
|
||||
ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.menus
|
||||
ui.gadgets.wrappers ui.render ui.text ui.gestures math.geometry.rect
|
||||
splitting unicode.categories fonts ;
|
||||
sequences strings math.vectors math.functions sorting colors
|
||||
combinators assocs math.order fry calendar alarms continuations
|
||||
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
|
||||
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
|
||||
ui.gadgets.theme ui.gadgets.menus ui.gadgets.wrappers ui.render
|
||||
ui.text ui.gestures math.geometry.rect splitting unicode.categories
|
||||
fonts ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor < gadget
|
||||
|
|
@ -133,7 +134,7 @@ M: editor ungraft*
|
|||
[ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
|
||||
|
||||
: loc>x ( loc editor -- x )
|
||||
[ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x ;
|
||||
[ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x round ;
|
||||
|
||||
: line>y ( lines# editor -- y )
|
||||
line-height * ;
|
||||
|
|
@ -222,7 +223,7 @@ M: editor ungraft*
|
|||
|
||||
: draw-selected-line ( start end n -- )
|
||||
[ start/end-on-line ] keep
|
||||
tuck [ swap 2array editor get loc>x ] 2bi@
|
||||
[ swap 2array editor get loc>x ] curry bi@
|
||||
(draw-selection) ;
|
||||
|
||||
: draw-selection ( -- )
|
||||
|
|
@ -347,7 +348,7 @@ M: editor gadget-text* editor-string % ;
|
|||
dupd editor-select-next mark>caret ;
|
||||
|
||||
: editor-select ( from to editor -- )
|
||||
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
|
||||
[ mark>> set-model ] [ caret>> set-model ] bi-curry bi* ;
|
||||
|
||||
: select-elt ( editor elt -- )
|
||||
[ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ TUPLE: frame < grid ;
|
|||
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
|
||||
|
||||
: fill-center ( dim horiz vert -- )
|
||||
[ over ] dip [ (fill-center) ] 2bi@ ;
|
||||
[ (fill-center) ] bi-curry@ bi ;
|
||||
|
||||
M: frame layout*
|
||||
dup compute-grid
|
||||
|
|
|
|||
|
|
@ -190,10 +190,18 @@ GENERIC: pref-dim* ( gadget -- dim )
|
|||
|
||||
M: gadget pref-dim* dim>> ;
|
||||
|
||||
SYMBOL: +baseline+
|
||||
|
||||
GENERIC: baseline ( gadget -- y )
|
||||
|
||||
M: gadget baseline pref-dim second ;
|
||||
|
||||
: baseline-align ( gadgets -- ys )
|
||||
[ { } ] [
|
||||
[ baseline ] map [ supremum ] keep
|
||||
[ - ] with map
|
||||
] if-empty ;
|
||||
|
||||
GENERIC: layout* ( gadget -- )
|
||||
|
||||
M: gadget layout* drop ;
|
||||
|
|
@ -315,25 +323,24 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: ((add-gadget)) ( parent child -- parent )
|
||||
over children>> ?push >>children ;
|
||||
|
||||
: (add-gadget) ( parent child -- parent )
|
||||
dup unparent
|
||||
over >>parent
|
||||
tuck ((add-gadget))
|
||||
tuck graft-state>> second [ graft ] [ drop ] if ;
|
||||
: (add-gadget) ( child parent -- )
|
||||
{
|
||||
[ drop unparent ]
|
||||
[ >>parent drop ]
|
||||
[ [ ?push ] change-children drop ]
|
||||
[ graft-state>> second [ graft ] [ drop ] if ]
|
||||
} 2cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-gadget ( parent child -- parent )
|
||||
not-in-layout
|
||||
(add-gadget)
|
||||
over (add-gadget)
|
||||
dup relayout ;
|
||||
|
||||
: add-gadgets ( parent children -- parent )
|
||||
not-in-layout
|
||||
[ (add-gadget) ] each
|
||||
[ over (add-gadget) ] each
|
||||
dup relayout ;
|
||||
|
||||
: parents ( gadget -- seq )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@ IN: ui.gadgets.grids
|
|||
TUPLE: grid < gadget
|
||||
grid
|
||||
{ gap initial: { 0 0 } }
|
||||
{ fill? initial: t } ;
|
||||
{ fill? initial: t }
|
||||
align ;
|
||||
|
||||
: new-grid ( children class -- grid )
|
||||
new-gadget
|
||||
|
|
@ -49,7 +50,7 @@ grid
|
|||
|
||||
M: grid pref-dim*
|
||||
[ gap>> ] [ compute-grid ] bi
|
||||
[ over ] dip [ gap-sum ] 2bi@ (pair-up) ;
|
||||
[ gap-sum ] bi-curry@ bi (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
[ grid>> ] dip '[ _ 2each ] 2each ; inline
|
||||
|
|
@ -58,7 +59,7 @@ M: grid pref-dim*
|
|||
[ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
|
||||
|
||||
: position-grid ( grid horiz vert -- )
|
||||
pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
|
||||
pick [ [ grid-positions ] bi-curry@ bi pair-up ] dip
|
||||
[ (>>loc) ] do-grid ;
|
||||
|
||||
: resize-grid ( grid horiz vert -- )
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: incremental dim-changed drop ;
|
|||
|
||||
: add-incremental ( gadget incremental -- )
|
||||
not-in-layout
|
||||
2dup swap (add-gadget) drop
|
||||
2dup (add-gadget)
|
||||
t in-layout? [
|
||||
{
|
||||
[ drop prefer-incremental ]
|
||||
|
|
|
|||
|
|
@ -108,14 +108,12 @@ C: <pane-stream> pane-stream
|
|||
[ prepare-line ] bi ;
|
||||
|
||||
: pane-write ( seq pane -- )
|
||||
[ '[ _ pane-nl ] ]
|
||||
[ '[ _ current>> stream-write ] ] bi
|
||||
interleave ;
|
||||
[ pane-nl ] [ current>> stream-write ]
|
||||
bi-curry interleave ;
|
||||
|
||||
: pane-format ( seq style pane -- )
|
||||
[ '[ _ drop _ pane-nl ] ]
|
||||
[ '[ _ _ current>> stream-format ] ] 2bi
|
||||
interleave ;
|
||||
[ nip pane-nl ] [ current>> stream-format ]
|
||||
bi-curry bi-curry interleave ;
|
||||
|
||||
GENERIC: write-gadget ( gadget stream -- )
|
||||
|
||||
|
|
@ -329,8 +327,7 @@ M: paragraph stream-format
|
|||
gadget-format
|
||||
] [
|
||||
[ " " split ] 2dip
|
||||
[ '[ _ _ gadget-bl ] ]
|
||||
[ '[ _ _ gadget-format ] ] 2bi
|
||||
[ gadget-bl ] [ gadget-format ] bi-curry bi-curry
|
||||
interleave
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -129,16 +129,15 @@ M: elevator layout*
|
|||
'[ _ swap find-slider slide-by-line ] <repeat-button>
|
||||
swap >>orientation ;
|
||||
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
: add-elevator ( gadget orientation -- gadget )
|
||||
[ <elevator> >>elevator ] [ <thumb> >>thumb ] bi
|
||||
dup [ elevator>> ] [ thumb>> ] bi add-gadget
|
||||
@center grid-add ;
|
||||
|
||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
|
||||
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
|
||||
: <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ;
|
||||
: <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ;
|
||||
: <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ;
|
||||
: <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ;
|
||||
|
||||
: <slider> ( range orientation -- slider )
|
||||
slider new-frame
|
||||
|
|
@ -149,16 +148,16 @@ M: elevator layout*
|
|||
: <x-slider> ( range -- slider )
|
||||
horizontal <slider>
|
||||
<left-button> @left grid-add
|
||||
vertical elevator,
|
||||
vertical add-elevator
|
||||
<right-button> @right grid-add ;
|
||||
|
||||
: <y-slider> ( range -- slider )
|
||||
vertical <slider>
|
||||
<up-button> @top grid-add
|
||||
horizontal elevator,
|
||||
horizontal add-elevator
|
||||
<down-button> @bottom grid-add ;
|
||||
|
||||
M: slider pref-dim*
|
||||
dup call-next-method
|
||||
swap orientation>> [ 40 v*n ] keep
|
||||
[ call-next-method ] [ orientation>> ] bi
|
||||
[ 40 v*n ] keep
|
||||
set-axis ;
|
||||
|
|
|
|||
|
|
@ -178,8 +178,8 @@ M: table draw-gadget*
|
|||
{
|
||||
[ draw-selected ]
|
||||
[ draw-columns ]
|
||||
[ draw-moused ]
|
||||
[ draw-rows ]
|
||||
[ draw-moused ]
|
||||
} cleave
|
||||
] with-translation
|
||||
] if ;
|
||||
|
|
@ -295,7 +295,8 @@ PRIVATE>
|
|||
|
||||
: show-table-menu ( table -- )
|
||||
[
|
||||
tuck [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri
|
||||
[ nip ]
|
||||
[ [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri ] 2bi
|
||||
show-operations-menu
|
||||
] [ drop ] if-mouse-row ;
|
||||
|
||||
|
|
|
|||
|
|
@ -158,8 +158,8 @@ CONSTANT: completion-popup-offset { -4 0 }
|
|||
?if ;
|
||||
|
||||
: completion-gesture ( gesture completion -- value/f operation/f )
|
||||
table>> selected-row [ tuck ] dip
|
||||
[ gesture>operation ] [ 2drop f ] if ;
|
||||
table>> selected-row
|
||||
[ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
|
||||
|
||||
M: completion-popup handle-gesture ( gesture completion -- ? )
|
||||
2dup completion-gesture dup [
|
||||
|
|
|
|||
|
|
@ -54,12 +54,12 @@ IN: validators
|
|||
] if ;
|
||||
|
||||
: v-regexp ( str what regexp -- str )
|
||||
[ over ] dip matches?
|
||||
[ drop ] [ "invalid " prepend throw ] if ;
|
||||
3dup nip matches?
|
||||
[ 2drop ] [ drop "invalid " prepend throw ] if ;
|
||||
|
||||
: v-email ( str -- str )
|
||||
#! From http://www.regular-expressions.info/email.html
|
||||
60 v-max-length
|
||||
320 v-max-length
|
||||
"e-mail"
|
||||
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
||||
v-regexp ;
|
||||
|
|
|
|||
|
|
@ -87,9 +87,9 @@ unless
|
|||
if ;
|
||||
|
||||
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
|
||||
[ '[ _ '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
|
||||
[ '[ _ [ swap 2array ] curry map ] ] bi bi*
|
||||
swap append ;
|
||||
[ '[ @ com-unwrap ] [ swap 2array ] curry map ]
|
||||
[ [ swap 2array ] curry map ] bi-curry bi*
|
||||
prepend ;
|
||||
|
||||
: compile-alien-callback ( word return parameters abi quot -- word )
|
||||
'[ _ _ _ _ alien-callback ]
|
||||
|
|
|
|||
|
|
@ -26,8 +26,7 @@ MACRO: drop-input ( quot -- newquot )
|
|||
infer in>> '[ _ ndrop ] ;
|
||||
|
||||
: fails? ( quot -- ? )
|
||||
[ '[ _ drop-output f ] ]
|
||||
[ '[ drop _ drop-input t ] ] bi recover ; inline
|
||||
[ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
|
||||
|
||||
: well-formed? ( uri -- answer )
|
||||
[ file>xml ] fails? "not-wf" "valid" ? ;
|
||||
|
|
|
|||
|
|
@ -14,10 +14,10 @@ IN: xml.writer.tests
|
|||
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
|
||||
|
||||
: reprints-as ( to from -- )
|
||||
[ '[ _ ] ] [ '[ _ string>xml xml>string ] ] bi* unit-test ;
|
||||
[ ] [ string>xml xml>string ] bi-curry* unit-test ;
|
||||
|
||||
: pprint-reprints-as ( to from -- )
|
||||
[ '[ _ ] ] [ '[ _ string>xml pprint-xml>string ] ] bi* unit-test ;
|
||||
[ ] [ string>xml pprint-xml>string ] bi-curry* unit-test ;
|
||||
|
||||
: reprints-same ( string -- ) dup reprints-as ;
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ PRIVATE>
|
|||
|
||||
: assoc-partition ( assoc quot -- true-assoc false-assoc )
|
||||
[ (assoc-each) partition ] [ drop ] 2bi
|
||||
tuck [ assoc-like ] 2bi@ ; inline
|
||||
[ assoc-like ] curry bi@ ; inline
|
||||
|
||||
: assoc-any? ( assoc quot -- ? )
|
||||
assoc-find 2nip ; inline
|
||||
|
|
|
|||
|
|
@ -251,9 +251,9 @@ M: tuple-class update-class
|
|||
3bi ;
|
||||
|
||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
[ over ] dip
|
||||
[ [ superclass ] [ bootstrap-word ] bi* = ]
|
||||
[ [ "slots" word-prop ] dip = ] 2bi* and ;
|
||||
[ [ "slots" word-prop ] dip = ]
|
||||
bi-curry* bi and ;
|
||||
|
||||
: valid-superclass? ( class -- ? )
|
||||
[ tuple-class? ] [ tuple eq? ] bi or ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ kernel.private accessors eval ;
|
|||
IN: continuations.tests
|
||||
|
||||
: (callcc1-test)
|
||||
swap 1- tuck swap ?push
|
||||
[ 1- dup ] dip ?push
|
||||
over 0 = [ "test-cc" get continue-with ] when
|
||||
(callcc1-test) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,10 +33,11 @@ PREDICATE: math-class < class
|
|||
|
||||
: math-upgrade ( class1 class2 -- quot )
|
||||
[ math-class-max ] 2keep
|
||||
[ over ] dip (math-upgrade) [
|
||||
[
|
||||
(math-upgrade)
|
||||
dup empty? [ [ dip ] curry [ ] like ] unless
|
||||
] dip append ;
|
||||
] [ (math-upgrade) ]
|
||||
bi-curry* bi append ;
|
||||
|
||||
ERROR: no-math-method left right generic ;
|
||||
|
||||
|
|
|
|||
|
|
@ -74,7 +74,8 @@ M: decoder stream-read1
|
|||
} cond ; inline
|
||||
|
||||
M: decoder stream-read
|
||||
tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
|
||||
[ nip ] [ >decoder< [ decode-char ] 2curry (read) finish-read ] 2bi
|
||||
fix-read ;
|
||||
|
||||
M: decoder stream-read-partial stream-read ;
|
||||
|
||||
|
|
|
|||
|
|
@ -184,6 +184,29 @@ GENERIC: boa ( ... class -- tuple )
|
|||
: prepose ( quot1 quot2 -- compose )
|
||||
swap compose ; inline
|
||||
|
||||
! Curried cleavers
|
||||
<PRIVATE
|
||||
|
||||
: schönfinkel ( quot -- quot' ) [ curry ] curry ; inline
|
||||
|
||||
: bi-schönfinkel ( p q -- p' q' ) [ schönfinkel ] bi@ ; inline
|
||||
|
||||
: tri-schönfinkel ( p q r -- p' q' r' ) [ schönfinkel ] tri@ ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bi-curry ( x p q -- p' q' ) bi-schönfinkel bi ; inline
|
||||
|
||||
: tri-curry ( x p q r -- p' q' r' ) tri-schönfinkel tri ; inline
|
||||
|
||||
: bi-curry* ( x y p q -- p' q' ) bi-schönfinkel bi* ; inline
|
||||
|
||||
: tri-curry* ( x y z p q r -- p' q' r' ) tri-schönfinkel tri* ; inline
|
||||
|
||||
: bi-curry@ ( x y q -- p' q' ) schönfinkel bi@ ; inline
|
||||
|
||||
: tri-curry@ ( x y z q -- p' q' r' ) schönfinkel tri@ ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) [ f ] [ t ] if ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors namespaces math words strings
|
||||
io vectors arrays math.parser combinators continuations ;
|
||||
|
|
@ -23,13 +23,11 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
lexer new-lexer ;
|
||||
|
||||
: skip ( i seq ? -- n )
|
||||
[ tuck ] dip
|
||||
[ swap CHAR: \s eq? xor ] curry find-from drop
|
||||
[ ] [ length ] ?if ;
|
||||
over length
|
||||
[ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
|
||||
|
||||
: change-lexer-column ( lexer quot -- )
|
||||
swap
|
||||
[ [ column>> ] [ line-text>> ] bi rot call ] keep
|
||||
[ [ column>> ] [ line-text>> ] bi ] prepose keep
|
||||
(>>column) ; inline
|
||||
|
||||
GENERIC: skip-blank ( lexer -- )
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
|
||||
: pre-scale ( num den -- scale shifted-num scaled-den )
|
||||
2dup [ log2 ] bi@ -
|
||||
tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
|
||||
[ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi*
|
||||
-rot ; inline
|
||||
|
||||
! Second step: loop
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ PRIVATE>
|
|||
|
||||
: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable
|
||||
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
|
||||
|
||||
: 2^ ( n -- 2^n ) 1 swap shift ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -128,8 +128,8 @@ INSTANCE: iota immutable-sequence
|
|||
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
|
||||
|
||||
: exchange-unsafe ( m n seq -- )
|
||||
[ tuck [ nth-unsafe ] 2bi@ ]
|
||||
[ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
|
||||
[ [ nth-unsafe ] curry bi@ ]
|
||||
[ [ set-nth-unsafe ] curry bi@ ] 3bi ; inline
|
||||
|
||||
: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
|
||||
|
||||
|
|
@ -205,7 +205,7 @@ TUPLE: slice
|
|||
{ seq read-only } ;
|
||||
|
||||
: collapse-slice ( m n slice -- m' n' seq )
|
||||
[ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline
|
||||
[ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
|
||||
|
||||
ERROR: slice-error from to seq reason ;
|
||||
|
||||
|
|
@ -357,7 +357,7 @@ PRIVATE>
|
|||
[ (each) ] dip collect ; inline
|
||||
|
||||
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
|
||||
[ over ] dip [ nth-unsafe ] 2bi@ ; inline
|
||||
[ nth-unsafe ] bi-curry@ bi ; inline
|
||||
|
||||
: (2each) ( seq1 seq2 quot -- n quot' )
|
||||
[
|
||||
|
|
@ -366,12 +366,12 @@ PRIVATE>
|
|||
] dip compose ; inline
|
||||
|
||||
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
|
||||
[ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
|
||||
[ nth-unsafe ] tri-curry@ tri ; inline
|
||||
|
||||
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
|
||||
[
|
||||
[ [ length ] tri@ min min ] 3keep
|
||||
[ 3nth-unsafe ] 3curry
|
||||
[ [ length ] tri@ min min ]
|
||||
[ [ 3nth-unsafe ] 3curry ] 3bi
|
||||
] dip compose ; inline
|
||||
|
||||
: finish-find ( i seq -- i elt )
|
||||
|
|
@ -470,7 +470,7 @@ PRIVATE>
|
|||
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
|
||||
|
||||
: partition ( seq quot -- trueseq falseseq )
|
||||
over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
|
||||
over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
|
||||
|
||||
: accumulator ( quot -- quot' vec )
|
||||
V{ } clone [ [ push ] curry compose ] keep ; inline
|
||||
|
|
@ -653,8 +653,14 @@ PRIVATE>
|
|||
: delete-nth ( n seq -- )
|
||||
[ dup 1+ ] dip delete-slice ;
|
||||
|
||||
: snip ( from to seq -- head tail )
|
||||
[ swap head ] [ swap tail ] bi-curry bi* ; inline
|
||||
|
||||
: snip-slice ( from to seq -- head tail )
|
||||
[ swap head-slice ] [ swap tail-slice ] bi-curry bi* ; inline
|
||||
|
||||
: replace-slice ( new from to seq -- seq' )
|
||||
tuck [ swap head-slice ] [ swap tail-slice ] 2bi* surround ;
|
||||
snip-slice surround ;
|
||||
|
||||
: remove-nth ( n seq -- seq' )
|
||||
[ [ { } ] dip dup 1+ ] dip replace-slice ;
|
||||
|
|
@ -663,14 +669,14 @@ PRIVATE>
|
|||
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
|
||||
|
||||
: exchange ( m n seq -- )
|
||||
pick over bounds-check 2drop 2dup bounds-check 2drop
|
||||
exchange-unsafe ;
|
||||
[ nip bounds-check 2drop ]
|
||||
[ bounds-check 3drop ]
|
||||
[ exchange-unsafe ]
|
||||
3tri ;
|
||||
|
||||
: reverse-here ( seq -- )
|
||||
dup length dup 2/ [
|
||||
[ 2dup ] dip
|
||||
tuck - 1- rot exchange-unsafe
|
||||
] each 2drop ;
|
||||
[ length 2/ ] [ length ] [ ] tri
|
||||
[ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
|
||||
|
||||
: reverse ( seq -- newseq )
|
||||
[
|
||||
|
|
@ -787,7 +793,7 @@ PRIVATE>
|
|||
|
||||
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
|
||||
2dup mismatch [ 2dup min-length ] unless*
|
||||
tuck [ tail-slice ] 2bi@ ;
|
||||
[ tail-slice ] curry bi@ ;
|
||||
|
||||
: unclip ( seq -- rest first )
|
||||
[ rest ] [ first-unsafe ] bi ;
|
||||
|
|
|
|||
|
|
@ -42,11 +42,11 @@ $nl
|
|||
" \"alice@bigcorp.com\" >>from"
|
||||
"send-email"
|
||||
}
|
||||
"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
|
||||
"The above has less shuffling than the writer version:"
|
||||
{ $code
|
||||
"<email>"
|
||||
" tuck (>>subject)"
|
||||
" tuck (>>to)"
|
||||
" [ (>>subject) ] keep"
|
||||
" [ (>>to) ] keep"
|
||||
" \"alice@bigcorp.com\" over (>>from)"
|
||||
"send-email"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -137,9 +137,9 @@ TUPLE: merge
|
|||
[ drop nip nth ] dip push
|
||||
] [
|
||||
[
|
||||
[ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq?
|
||||
[ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
|
||||
[ swap ] when
|
||||
] dip tuck [ push ] 2bi@
|
||||
] dip [ push ] curry bi@
|
||||
] if ; inline
|
||||
|
||||
: sort-pairs ( merge quot -- )
|
||||
|
|
|
|||
|
|
@ -31,9 +31,8 @@ uses definitions ;
|
|||
source-files get [ nip xref-source ] assoc-each ;
|
||||
|
||||
: record-form ( quot source-file -- )
|
||||
tuck unxref-source
|
||||
quot-uses keys >>uses
|
||||
xref-source ;
|
||||
[ quot-uses keys ] dip
|
||||
[ unxref-source ] [ (>>uses) ] [ xref-source ] tri ;
|
||||
|
||||
: record-definitions ( file -- )
|
||||
new-definitions get >>definitions drop ;
|
||||
|
|
|
|||
|
|
@ -4,35 +4,46 @@ USING: kernel math make strings arrays vectors sequences
|
|||
sets math.order accessors ;
|
||||
IN: splitting
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ?chomp ( seq begin tester chopper -- newseq ? )
|
||||
[ [ 2dup ] dip call ] dip
|
||||
[ [ length ] dip call t ] curry
|
||||
[ drop f ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ?head ( seq begin -- newseq ? )
|
||||
2dup head? [ length tail t ] [ drop f ] if ;
|
||||
[ head? ] [ tail ] ?chomp ;
|
||||
|
||||
: ?head-slice ( seq begin -- newseq ? )
|
||||
2dup head? [ length tail-slice t ] [ drop f ] if ;
|
||||
[ head? ] [ tail-slice ] ?chomp ;
|
||||
|
||||
: ?tail ( seq end -- newseq ? )
|
||||
2dup tail? [ length head* t ] [ drop f ] if ;
|
||||
[ tail? ] [ head* ] ?chomp ;
|
||||
|
||||
: ?tail-slice ( seq end -- newseq ? )
|
||||
2dup tail? [ length head-slice* t ] [ drop f ] if ;
|
||||
[ tail? ] [ head-slice* ] ?chomp ;
|
||||
|
||||
: (split1) ( seq subseq -- start end ? )
|
||||
tuck swap start dup
|
||||
[ swap [ drop ] [ length + ] 2bi t ]
|
||||
[ 2drop f f f ]
|
||||
if ;
|
||||
<PRIVATE
|
||||
|
||||
: (split1) ( seq subseq quot -- before after )
|
||||
[
|
||||
swap [
|
||||
[ drop length ] [ start dup ] 2bi
|
||||
[ [ nip ] [ + ] 2bi t ]
|
||||
[ 2drop f f f ]
|
||||
if
|
||||
] keep swap
|
||||
] dip [ 2nip f ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: split1 ( seq subseq -- before after )
|
||||
[ drop ] [ (split1) ] 2bi
|
||||
[ [ over ] dip [ head ] [ tail ] 2bi* ]
|
||||
[ 2drop f ]
|
||||
if ;
|
||||
[ snip ] (split1) ;
|
||||
|
||||
: split1-slice ( seq subseq -- before-slice after-slice )
|
||||
[ drop ] [ (split1) ] 2bi
|
||||
[ [ over ] dip [ head-slice ] [ tail-slice ] 2bi* ]
|
||||
[ 2drop f ]
|
||||
if ;
|
||||
[ snip-slice ] (split1) ;
|
||||
|
||||
: split1-last ( seq subseq -- before after )
|
||||
[ <reversed> ] bi@ split1 [ reverse ] bi@
|
||||
|
|
@ -49,7 +60,8 @@ IN: splitting
|
|||
|
||||
: split, ( seq separators -- ) 0 rot (split) ;
|
||||
|
||||
: split ( seq separators -- pieces ) [ split, ] { } make ;
|
||||
: split ( seq separators -- pieces )
|
||||
[ split, ] { } make ;
|
||||
|
||||
: string-lines ( str -- seq )
|
||||
dup "\r\n" intersects? [
|
||||
|
|
|
|||
|
|
@ -109,10 +109,9 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at
|
|||
|
||||
: compiled-xref ( word dependencies generic-dependencies -- )
|
||||
[ [ drop crossref? ] { } assoc-filter-as f like ] bi@
|
||||
[ over ] dip
|
||||
[ "compiled-uses" compiled-crossref (compiled-xref) ]
|
||||
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
|
||||
2bi* ;
|
||||
bi-curry* bi ;
|
||||
|
||||
: (compiled-unxref) ( word word-prop variable -- )
|
||||
[ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue