sequences: define ?first and ?second.
							parent
							
								
									fb178b19a3
								
							
						
					
					
						commit
						3207244c60
					
				| 
						 | 
					@ -152,7 +152,7 @@ ERROR: no-defined-persistent object ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: select-tuple ( query/tuple -- tuple/f )
 | 
					: select-tuple ( query/tuple -- tuple/f )
 | 
				
			||||||
    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
 | 
					    >query 1 >>limit [ tuple>> ] [ query>statement ] bi
 | 
				
			||||||
    do-select [ f ] [ first ] if-empty ;
 | 
					    do-select ?first ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: count-tuples ( query/tuple -- n )
 | 
					: count-tuples ( query/tuple -- n )
 | 
				
			||||||
    >query [ tuple>> ] [ <count-statement> ] bi do-count
 | 
					    >query [ tuple>> ] [ <count-statement> ] bi do-count
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -82,8 +82,6 @@ DEFER: (parse-paragraph)
 | 
				
			||||||
        [ [ parse-paragraph ] or-simple-title link boa ] if
 | 
					        [ [ parse-paragraph ] or-simple-title link boa ] if
 | 
				
			||||||
    ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
 | 
					    ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: ?first ( seq -- elt ) 0 swap ?nth ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: parse-big-link ( before after -- link rest )
 | 
					: parse-big-link ( before after -- link rest )
 | 
				
			||||||
    dup ?first CHAR: [ =
 | 
					    dup ?first CHAR: [ =
 | 
				
			||||||
    [ parse-link ]
 | 
					    [ parse-link ]
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -277,7 +277,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
 | 
				
			||||||
    229 server-response ;
 | 
					    229 server-response ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: handle-MDTM ( obj -- )
 | 
					: handle-MDTM ( obj -- )
 | 
				
			||||||
    tokenized>> 1 swap ?nth [
 | 
					    tokenized>> ?second [
 | 
				
			||||||
        fixup-relative-path
 | 
					        fixup-relative-path
 | 
				
			||||||
        dup file-info dup directory? [
 | 
					        dup file-info dup directory? [
 | 
				
			||||||
            drop not-a-plain-file
 | 
					            drop not-a-plain-file
 | 
				
			||||||
| 
						 | 
					@ -300,7 +300,7 @@ ERROR: no-directory-permissions ;
 | 
				
			||||||
    "Failed to change directory." 553 server-response ;
 | 
					    "Failed to change directory." 553 server-response ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: handle-CWD ( obj -- )
 | 
					: handle-CWD ( obj -- )
 | 
				
			||||||
    tokenized>> 1 swap ?nth [
 | 
					    tokenized>> ?second [
 | 
				
			||||||
        fixup-relative-path
 | 
					        fixup-relative-path
 | 
				
			||||||
        dup can-serve-directory? [
 | 
					        dup can-serve-directory? [
 | 
				
			||||||
            set-current-directory
 | 
					            set-current-directory
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -70,7 +70,7 @@ CONSTANT: hat-switch-matching-hash
 | 
				
			||||||
    buttons-matching-hash device-elements-matching length ;
 | 
					    buttons-matching-hash device-elements-matching length ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: ?axis ( device hash -- axis/f )
 | 
					: ?axis ( device hash -- axis/f )
 | 
				
			||||||
    device-elements-matching [ f ] [ first ] if-empty ;
 | 
					    device-elements-matching ?first ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: ?x-axis ( device -- ? )
 | 
					: ?x-axis ( device -- ? )
 | 
				
			||||||
    x-axis-matching-hash ?axis ;
 | 
					    x-axis-matching-hash ?axis ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -26,6 +26,6 @@ M: merged virtual@ ( n seq -- n' seq' )
 | 
				
			||||||
    seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline
 | 
					    seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: merged virtual-exemplar ( merged -- seq )
 | 
					M: merged virtual-exemplar ( merged -- seq )
 | 
				
			||||||
    seqs>> [ f ] [ first ] if-empty ; inline
 | 
					    seqs>> ?first ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
INSTANCE: merged virtual-sequence
 | 
					INSTANCE: merged virtual-sequence
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -15,8 +15,7 @@ C: <word> word
 | 
				
			||||||
    [ append ] [ [ words-length ] bi@ ] 2bi <element> ;
 | 
					    [ append ] [ [ words-length ] bi@ ] 2bi <element> ;
 | 
				
			||||||
 
 | 
					 
 | 
				
			||||||
: ?first2 ( seq -- first/f second/f )
 | 
					: ?first2 ( seq -- first/f second/f )
 | 
				
			||||||
    [ 0 swap ?nth ]
 | 
					    [ ?first ] [ ?second ] bi ;
 | 
				
			||||||
    [ 1 swap ?nth ] bi ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: split-words ( seq -- half-elements )
 | 
					: split-words ( seq -- half-elements )
 | 
				
			||||||
    [ [ break?>> ] bi@ = ] monotonic-split ;
 | 
					    [ [ break?>> ] bi@ = ] monotonic-split ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -83,8 +83,6 @@ M: closer process
 | 
				
			||||||
    ! this does *not* affect the contents of the stack
 | 
					    ! this does *not* affect the contents of the stack
 | 
				
			||||||
    [ notags ] unless* ;
 | 
					    [ notags ] unless* ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: ?first ( seq -- elt/f ) 0 swap ?nth ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
: get-prolog ( seq -- prolog )
 | 
					: get-prolog ( seq -- prolog )
 | 
				
			||||||
    { "" } ?head drop
 | 
					    { "" } ?head drop
 | 
				
			||||||
    ?first dup prolog?
 | 
					    ?first dup prolog?
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -179,6 +179,14 @@ HELP: ?nth
 | 
				
			||||||
{ $values { "n" "an integer" } { "seq" sequence } { "elt/f" "an object or " { $link f } } }
 | 
					{ $values { "n" "an integer" } { "seq" sequence } { "elt/f" "an object or " { $link f } } }
 | 
				
			||||||
{ $description "A forgiving version of " { $link nth } ". If the index is out of bounds, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
 | 
					{ $description "A forgiving version of " { $link nth } ". If the index is out of bounds, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					HELP: ?first
 | 
				
			||||||
 | 
					{ $values { "seq" sequence } { "elt/f" "an object or " { $link f } } }
 | 
				
			||||||
 | 
					{ $description "A forgiving version of " { $link first } ". If the sequence is empty, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					HELP: ?second
 | 
				
			||||||
 | 
					{ $values { "seq" sequence } { "elt/f" "an object or " { $link f } } }
 | 
				
			||||||
 | 
					{ $description "A forgiving version of " { $link second } ". If the sequence has less than two elements, or if the sequence is " { $link f } ", simply outputs " { $link f } "." } ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
HELP: nth-unsafe
 | 
					HELP: nth-unsafe
 | 
				
			||||||
{ $values { "n" "an integer" } { "seq" sequence } { "elt" object } }
 | 
					{ $values { "n" "an integer" } { "seq" sequence } { "elt" object } }
 | 
				
			||||||
{ $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ;
 | 
					{ $contract "Unsafe variant of " { $link nth } " that does not perform bounds checks." } ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -241,6 +241,10 @@ unit-test
 | 
				
			||||||
[ -3 10 iota nth ] must-fail
 | 
					[ -3 10 iota nth ] must-fail
 | 
				
			||||||
[ 11 10 iota nth ] must-fail
 | 
					[ 11 10 iota nth ] must-fail
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					[ f ] [ f ?first ] unit-test
 | 
				
			||||||
 | 
					[ f ] [ { } ?first ] unit-test
 | 
				
			||||||
 | 
					[ 0 ] [ 10 iota ?first ] unit-test
 | 
				
			||||||
 | 
					
 | 
				
			||||||
[ -1/0. 0 remove-nth! ] must-fail
 | 
					[ -1/0. 0 remove-nth! ] must-fail
 | 
				
			||||||
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
 | 
					[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
 | 
				
			||||||
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
 | 
					[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -175,6 +175,9 @@ PRIVATE>
 | 
				
			||||||
: ?nth ( n seq -- elt/f )
 | 
					: ?nth ( n seq -- elt/f )
 | 
				
			||||||
    2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
 | 
					    2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: ?first ( seq -- elt/f ) 0 swap ?nth ; inline
 | 
				
			||||||
 | 
					: ?second ( seq -- elt/f ) 1 swap ?nth ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
MIXIN: virtual-sequence
 | 
					MIXIN: virtual-sequence
 | 
				
			||||||
GENERIC: virtual-exemplar ( seq -- seq' )
 | 
					GENERIC: virtual-exemplar ( seq -- seq' )
 | 
				
			||||||
GENERIC: virtual@ ( n seq -- n' seq' )
 | 
					GENERIC: virtual@ ( n seq -- n' seq' )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -506,7 +506,7 @@ TYPED:: virtual-address-segment ( elf: Elf32/64_Ehdr address -- program-header/f
 | 
				
			||||||
    elf elf-program-headers elf-loadable-segments [
 | 
					    elf elf-program-headers elf-loadable-segments [
 | 
				
			||||||
        [ p_vaddr>> dup ] [ p_memsz>> + ] bi [a,b)
 | 
					        [ p_vaddr>> dup ] [ p_memsz>> + ] bi [a,b)
 | 
				
			||||||
        address swap interval-contains?
 | 
					        address swap interval-contains?
 | 
				
			||||||
    ] filter [ f ] [ first ] if-empty ;
 | 
					    ] find nip ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f )
 | 
					TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f )
 | 
				
			||||||
    elf address virtual-address-segment :> segment
 | 
					    elf address virtual-address-segment :> segment
 | 
				
			||||||
| 
						 | 
					@ -515,7 +515,7 @@ TYPED:: virtual-address-section ( elf: Elf32/64_Ehdr address -- section-header/f
 | 
				
			||||||
    sections [
 | 
					    sections [
 | 
				
			||||||
        [ sh_offset>> dup ] [ sh_size>> + ] bi [a,b)
 | 
					        [ sh_offset>> dup ] [ sh_size>> + ] bi [a,b)
 | 
				
			||||||
        faddress swap interval-contains?
 | 
					        faddress swap interval-contains?
 | 
				
			||||||
    ] filter [ f ] [ first ] if-empty ;
 | 
					    ] find nip ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f )
 | 
					TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f )
 | 
				
			||||||
    header [ p_offset>> elf >c-ptr <displaced-alien> ] [ p_filesz>> ] bi uchar <c-direct-array> ;
 | 
					    header [ p_offset>> elf >c-ptr <displaced-alien> ] [ p_filesz>> ] bi uchar <c-direct-array> ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -65,7 +65,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: send-query-1result ( collection assoc -- result )
 | 
					: send-query-1result ( collection assoc -- result )
 | 
				
			||||||
    <mdb-query-msg> -1 >>return# send-query-plain
 | 
					    <mdb-query-msg> -1 >>return# send-query-plain
 | 
				
			||||||
    objects>> [ f ] [ first ] if-empty ;
 | 
					    objects>> ?first ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: send-cmd ( cmd -- result )
 | 
					: send-cmd ( cmd -- result )
 | 
				
			||||||
    [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
 | 
					    [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -240,9 +240,8 @@ M: mdb-cursor find
 | 
				
			||||||
    t >>explain find nip . ;
 | 
					    t >>explain find nip . ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: find-one ( mdb-query-msg -- result/f )
 | 
					: find-one ( mdb-query-msg -- result/f )
 | 
				
			||||||
    fix-query-collection 
 | 
					    fix-query-collection 1 >>return#
 | 
				
			||||||
    1 >>return# send-query-plain objects>>
 | 
					    send-query-plain objects>> ?first ;
 | 
				
			||||||
    [ f ] [ first ] if-empty ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: count ( mdb-query-msg -- result )
 | 
					: count ( mdb-query-msg -- result )
 | 
				
			||||||
    [ count-cmd make-cmd ] dip
 | 
					    [ count-cmd make-cmd ] dip
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -72,7 +72,7 @@ M: summed set-length ( n seq -- )
 | 
				
			||||||
    seqs>> [ set-length ] with each ;
 | 
					    seqs>> [ set-length ] with each ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: summed virtual-exemplar ( summed -- seq )
 | 
					M: summed virtual-exemplar ( summed -- seq )
 | 
				
			||||||
    seqs>> [ f ] [ first ] if-empty ;
 | 
					    seqs>> ?first ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
 | 
					: <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
 | 
				
			||||||
: <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;
 | 
					: <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -72,7 +72,7 @@ MEMO: default-dictionary ( -- counts )
 | 
				
			||||||
    load-dictionary ;
 | 
					    load-dictionary ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: (correct) ( word dictionary -- word/f )
 | 
					: (correct) ( word dictionary -- word/f )
 | 
				
			||||||
    corrections [ f ] [ first ] if-empty ;
 | 
					    corrections ?first ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: correct ( word -- word/f )
 | 
					: correct ( word -- word/f )
 | 
				
			||||||
    default-dictionary (correct) ;
 | 
					    default-dictionary (correct) ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue