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
[ ] [ 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 ;
: 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 ;
] ($subsection) ;
: $vocab-link ( element -- )
- check-first dup vocab-name swap ($vocab-link) ;
+ check-first [ vocab-name ] keep ($vocab-link) ;
: $vocabulary ( element -- )
check-first vocabulary>> [
\ 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
+same-group+ >>group ;
: process-started? ( process -- ? )
- dup handle>> swap status>> or ;
+ [ handle>> ] [ status>> ] bi or ;
: process-running? ( process -- ? )
handle>> >boolean ;
2dup [ length ] bi@ + 1 - 2pad-tail ;
: p* ( p q -- r )
- 2unempty pextend-conv
+ 2unempty pextend-conv
[ drop length [ iota ] keep ]
[ nip <reversed> ]
[ drop ] 2tri
! 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
: 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
<<
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
>>
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 )
'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 )
[
'statement' parse values>> do-expressions
] { } make [ write ] each ;
-
: fjsc-literal ( ast -- string )
[
[ (literal) ] { } make [ write ] each
! 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
! 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
! 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
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>
: 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? ;
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 < ;