more minor cleanup.

db4
John Benediktsson 2014-11-30 19:26:23 -08:00
parent 1e8dedb808
commit 76761b2e59
13 changed files with 54 additions and 53 deletions

View File

@ -87,8 +87,9 @@ M: dlist equal?
PRIVATE>
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
dup next>> swap prev>> set-next-when ; inline
[ prev>> ] [ next>> ] bi
[ set-prev-when ]
[ swap set-next-when ] 2bi ; inline
M: dlist push-front* ( obj dlist -- dlist-node )
[ front>> f swap <dlist-node> dup dup set-next-prev ] keep

View File

@ -14,16 +14,16 @@ IN: formatting
[ ] [ compose ] reduce ; inline
: fix-sign ( string -- string )
dup CHAR: 0 swap index 0 =
[ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
[ dup 1 - rot dup [ nth ] dip swap
{
{ CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] }
{ CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] }
[ drop nip ]
dup first CHAR: 0 = [
dup [ [ CHAR: 0 = not ] [ digit? ] bi and ] find
[
1 - swap 2dup nth {
{ CHAR: - [ remove-nth "-" prepend ] }
{ CHAR: + [ remove-nth "+" prepend ] }
[ drop nip ]
} case
] [ drop ] if
] when ;
] [ drop ] if
] when ;
: >digits ( string -- digits )
[ 0 ] [ string>number ] if-empty ;

View File

@ -181,7 +181,7 @@ M: heap heap-pop ( heap -- value key )
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
[ [ heap-pop ] keep 2array ]
produce nip ;
ERROR: not-a-heap obj ;

View File

@ -267,7 +267,7 @@ PRIVATE>
] ($subsection) ;
: $vocab-link ( element -- )
check-first dup vocab-name swap ($vocab-link) ;
check-first [ vocab-name ] keep ($vocab-link) ;
: $vocabulary ( element -- )
check-first vocabulary>> [

View File

@ -219,7 +219,7 @@ DEFER: __
\ first4 [ 4array ] define-inverse
\ prefix \ unclip define-dual
\ suffix [ dup but-last swap last ] define-inverse
\ suffix \ unclip-last define-dual
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse

View File

@ -59,7 +59,7 @@ SYMBOL: +new-session+
+same-group+ >>group ;
: process-started? ( process -- ? )
dup handle>> swap status>> or ;
[ handle>> ] [ status>> ] bi or ;
: process-running? ( process -- ? )
handle>> >boolean ;

View File

@ -32,7 +32,7 @@ ALIAS: n*p n*v
2dup [ length ] bi@ + 1 - 2pad-tail ;
: p* ( p q -- r )
2unempty pextend-conv
2unempty pextend-conv
[ drop length [ iota ] keep ]
[ nip <reversed> ]
[ drop ] 2tri

View File

@ -74,7 +74,7 @@ TAG: KEYWORDS parse-rule-tag
! Top-level entry points
: parse-mode-tag ( tag -- rule-sets )
dup "RULES" tags-named [
parse-rules-tag dup name>> swap
parse-rules-tag [ name>> ] keep
] H{ } map>assoc
swap "PROPS" tag-named [
parse-props-tag over values

View File

@ -94,7 +94,7 @@ M: regexp text-matches?
: rule-end-matches? ( rule -- match-count/f )
dup mark-following-rule? [
dup start>> swap can-match-here? 0 and
[ start>> ] keep can-match-here? 0 and
] [
[ end>> dup ] keep can-match-here? [
rest-of-line

View File

@ -7,9 +7,13 @@ IN: xmode.tokens
<<
SYMBOL: tokens
{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
create-in dup define-symbol
dup name>> swap
{
"COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT"
"FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3"
"KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3"
"LITERAL4" "MARKUP" "OPERATOR" "END" "NULL"
} [
dup create-in dup define-symbol
] H{ } map>assoc tokens set-global
>>

View File

@ -311,31 +311,25 @@ M: number (parse-factor-quotation) ( object -- ast )
ast-number boa ;
M: symbol (parse-factor-quotation) ( object -- ast )
dup >string swap vocabulary>> ast-identifier boa ;
[ >string ] [ vocabulary>> ] bi ast-identifier boa ;
M: word (parse-factor-quotation) ( object -- ast )
dup name>> swap vocabulary>> ast-identifier boa ;
[ name>> ] [ vocabulary>> ] bi ast-identifier boa ;
M: string (parse-factor-quotation) ( object -- ast )
ast-string boa ;
M: quotation (parse-factor-quotation) ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make ast-quotation boa ;
[ (parse-factor-quotation) ] { } map-as ast-quotation boa ;
M: array (parse-factor-quotation) ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make ast-array boa ;
[ (parse-factor-quotation) ] { } map-as ast-array boa ;
M: hashtable (parse-factor-quotation) ( object -- ast )
>alist [
[ (parse-factor-quotation) , ] each
] { } make ast-hashtable boa ;
>alist [ (parse-factor-quotation) ] { } map-as ast-hashtable boa ;
M: wrapper (parse-factor-quotation) ( object -- ast )
wrapped>> dup name>> swap vocabulary>> ast-word boa ;
wrapped>> [ name>> ] [ vocabulary>> ] bi ast-word boa ;
GENERIC: fjsc-parse ( object -- ast )
@ -343,9 +337,7 @@ M: string fjsc-parse ( object -- ast )
'expression' parse ;
M: quotation fjsc-parse ( object -- ast )
[
[ (parse-factor-quotation) , ] each
] { } make ast-expression boa ;
[ (parse-factor-quotation) ] { } map-as ast-expression boa ;
: fjsc-compile ( ast -- string )
[
@ -364,7 +356,6 @@ M: quotation fjsc-parse ( object -- ast )
'statement' parse values>> do-expressions
] { } make [ write ] each ;
: fjsc-literal ( ast -- string )
[
[ (literal) ] { } make [ write ] each

View File

@ -8,8 +8,9 @@ IN: project-euler.018
! DESCRIPTION
! -----------
! By starting at the top of the triangle below and moving to adjacent numbers
! on the row below, the maximum total from top to bottom is 23.
! By starting at the top of the triangle below and moving to
! adjacent numbers on the row below, the maximum total from top
! to bottom is 23.
! 3
! 7 5
@ -18,7 +19,8 @@ IN: project-euler.018
! That is, 3 + 7 + 4 + 9 = 23.
! Find the maximum total from top to bottom of the triangle below:
! Find the maximum total from top to bottom of the triangle
! below:
! 75
! 95 64
@ -36,22 +38,24 @@ IN: project-euler.018
! 63 66 04 68 89 53 67 30 73 16 69 87 40 31
! 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
! NOTE: As there are only 16384 routes, it is possible to solve this problem by
! trying every route. However, Problem 67, is the same challenge with a
! triangle containing one-hundred rows; it cannot be solved by brute force, and
! requires a clever method! ;o)
! NOTE: As there are only 16384 routes, it is possible to solve
! this problem by trying every route. However, Problem 67, is
! the same challenge with a triangle containing one-hundred
! rows; it cannot be solved by brute force, and requires a
! clever method! ;o)
! SOLUTION
! --------
! Propagate from bottom to top the longest cumulative path. This is very
! efficient and will be reused in problem 67.
! Propagate from bottom to top the longest cumulative path. This
! is very efficient and will be reused in problem 67.
<PRIVATE
: source-018 ( -- triangle )
{ 75
{
75
95 64
17 47 82
18 35 87 10
@ -66,7 +70,7 @@ IN: project-euler.018
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
} 15 [1,b] [ cut swap ] map nip ;
} 15 [1,b] [ cut swap ] map nip ;
PRIVATE>

View File

@ -111,11 +111,12 @@ PRIVATE>
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
! Not strictly needed, but it is nice to be able to dump the
! triangle after the propagation
: propagate-all ( triangle -- new-triangle )
reverse [ first dup ] [ rest ] bi
[ propagate dup ] map nip reverse swap suffix ;
reverse unclip dup rot
[ propagate dup ] map nip
reverse swap suffix ;
: permutations? ( n m -- ? )
[ count-digits ] same? ;
@ -124,7 +125,7 @@ PRIVATE>
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
: sum-proper-divisors ( n -- sum )
dup sum-divisors swap - ;
[ sum-divisors ] keep - ;
: abundant? ( n -- ? )
dup sum-proper-divisors < ;