more minor cleanup.
parent
1e8dedb808
commit
76761b2e59
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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>> [
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
>>
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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 < ;
|
||||
|
|
Loading…
Reference in New Issue