steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/dlists/dlists.factor
View File

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

18
basis/formatting/formatting.factor
View File

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

2
basis/heaps/heaps.factor
View File

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

2
basis/help/markup/markup.factor
View File

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

2
basis/inverse/inverse.factor
View File

@ -219,7 +219,7 @@ DEFER: __
\ first4 [ 4array ] define-inverse \ first4 [ 4array ] define-inverse
\ prefix \ unclip define-dual \ 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 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse

2
basis/io/launcher/launcher.factor
View File

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

2
basis/xmode/loader/loader.factor
View File

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

2
basis/xmode/marker/marker.factor
View File

@ -94,7 +94,7 @@ M: regexp text-matches?
: rule-end-matches? ( rule -- match-count/f ) : rule-end-matches? ( rule -- match-count/f )
dup mark-following-rule? [ 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? [ [ end>> dup ] keep can-match-here? [
rest-of-line rest-of-line

10
basis/xmode/tokens/tokens.factor
View File

@ -7,9 +7,13 @@ IN: xmode.tokens
<< <<
SYMBOL: 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 "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT"
dup name>> swap "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 ] H{ } map>assoc tokens set-global
>> >>

23
extra/fjsc/fjsc.factor
View File

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

26
extra/project-euler/018/018.factor
View File

@ -8,8 +8,9 @@ IN: project-euler.018
! DESCRIPTION ! DESCRIPTION
! ----------- ! -----------
! By starting at the top of the triangle below and moving to adjacent numbers ! By starting at the top of the triangle below and moving to
! on the row below, the maximum total from top to bottom is 23. ! adjacent numbers on the row below, the maximum total from top
! to bottom is 23.
! 3 ! 3
! 7 5 ! 7 5
@ -18,7 +19,8 @@ IN: project-euler.018
! That is, 3 + 7 + 4 + 9 = 23. ! 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 ! 75
! 95 64 ! 95 64
@ -36,22 +38,24 @@ IN: project-euler.018
! 63 66 04 68 89 53 67 30 73 16 69 87 40 31 ! 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 ! 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 ! NOTE: As there are only 16384 routes, it is possible to solve
! trying every route. However, Problem 67, is the same challenge with a ! this problem by trying every route. However, Problem 67, is
! triangle containing one-hundred rows; it cannot be solved by brute force, and ! the same challenge with a triangle containing one-hundred
! requires a clever method! ;o) ! rows; it cannot be solved by brute force, and requires a
! clever method! ;o)
! SOLUTION ! SOLUTION
! -------- ! --------
! Propagate from bottom to top the longest cumulative path. This is very ! Propagate from bottom to top the longest cumulative path. This
! efficient and will be reused in problem 67. ! is very efficient and will be reused in problem 67.
<PRIVATE <PRIVATE
: source-018 ( -- triangle ) : source-018 ( -- triangle )
{ 75 {
75
95 64 95 64
17 47 82 17 47 82
18 35 87 10 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 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 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 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> PRIVATE>

11
extra/project-euler/common/common.factor
View File

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