Merge branch 'master' of git://factorcode.org/git/factor
commit
2f103f19ea
|
@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
|
||||||
classes.tuple continuations continuations.private combinators
|
classes.tuple continuations continuations.private combinators
|
||||||
generic.math io.streams.duplex classes.builtin classes
|
generic.math io.streams.duplex classes.builtin classes
|
||||||
compiler.units generic.standard vocabs threads threads.private
|
compiler.units generic.standard vocabs threads threads.private
|
||||||
init kernel.private libc io.encodings accessors ;
|
init kernel.private libc io.encodings mirrors accessors ;
|
||||||
IN: debugger
|
IN: debugger
|
||||||
|
|
||||||
GENERIC: error. ( error -- )
|
GENERIC: error. ( error -- )
|
||||||
|
@ -289,6 +289,10 @@ M: encode-error summary drop "Character encoding error" ;
|
||||||
|
|
||||||
M: decode-error summary drop "Character decoding error" ;
|
M: decode-error summary drop "Character decoding error" ;
|
||||||
|
|
||||||
|
M: no-such-slot summary drop "No such slot" ;
|
||||||
|
|
||||||
|
M: immutable-slot summary drop "Slot is immutable" ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: init-debugger ( -- )
|
: init-debugger ( -- )
|
||||||
|
|
|
@ -37,10 +37,6 @@ HELP: <mirror>
|
||||||
}
|
}
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: >mirror<
|
|
||||||
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
|
|
||||||
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
|
|
||||||
|
|
||||||
HELP: make-mirror
|
HELP: make-mirror
|
||||||
{ $values { "obj" object } { "assoc" assoc } }
|
{ $values { "obj" object } { "assoc" assoc } }
|
||||||
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
|
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: mirrors tools.test assocs kernel arrays ;
|
USING: mirrors tools.test assocs kernel arrays accessors ;
|
||||||
IN: mirrors.tests
|
IN: mirrors.tests
|
||||||
|
|
||||||
TUPLE: foo bar baz ;
|
TUPLE: foo bar baz ;
|
||||||
|
@ -14,3 +14,15 @@ C: <foo> foo
|
||||||
[ 3 ] [
|
[ 3 ] [
|
||||||
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
|
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
|
||||||
|
[ no-such-slot? ]
|
||||||
|
[ name>> "hi" = ]
|
||||||
|
[ object>> foo? ] tri and and
|
||||||
|
] must-fail-with
|
||||||
|
|
||||||
|
[ 3 "numerator" 1/2 <mirror> set-at ] [
|
||||||
|
[ immutable-slot? ]
|
||||||
|
[ name>> "numerator" = ]
|
||||||
|
[ object>> 1/2 = ] tri and and
|
||||||
|
] must-fail-with
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs hashtables kernel sequences generic words
|
USING: assocs hashtables kernel sequences generic words
|
||||||
arrays classes slots slots.private classes.tuple math vectors
|
arrays classes slots slots.private classes.tuple math vectors
|
||||||
quotations sorting prettyprint ;
|
quotations sorting prettyprint accessors ;
|
||||||
IN: mirrors
|
IN: mirrors
|
||||||
|
|
||||||
: all-slots ( class -- slots )
|
: all-slots ( class -- slots )
|
||||||
|
@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
|
||||||
: <mirror> ( object -- mirror )
|
: <mirror> ( object -- mirror )
|
||||||
dup object-slots mirror boa ;
|
dup object-slots mirror boa ;
|
||||||
|
|
||||||
: >mirror< ( mirror -- obj slots )
|
ERROR: no-such-slot object name ;
|
||||||
dup mirror-object swap mirror-slots ;
|
|
||||||
|
|
||||||
: mirror@ ( slot-name mirror -- obj slot-spec )
|
ERROR: immutable-slot object name ;
|
||||||
>mirror< swapd slot-named ;
|
|
||||||
|
|
||||||
M: mirror at*
|
M: mirror at*
|
||||||
mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
|
[ nip object>> ] [ slots>> slot-named ] 2bi
|
||||||
|
dup [ offset>> slot t ] [ 2drop f f ] if ;
|
||||||
|
|
||||||
M: mirror set-at ( val key mirror -- )
|
M: mirror set-at ( val key mirror -- )
|
||||||
mirror@ dup [
|
[ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
|
||||||
dup slot-spec-writer [
|
dup writer>> [
|
||||||
slot-spec-offset set-slot
|
nip offset>> set-slot
|
||||||
] [
|
] [
|
||||||
"Immutable slot" throw
|
drop immutable-slot
|
||||||
] if
|
] if
|
||||||
] [
|
] [
|
||||||
"No such slot" throw
|
drop no-such-slot
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: mirror delete-at ( key mirror -- )
|
M: mirror delete-at ( key mirror -- )
|
||||||
f -rot set-at ;
|
f -rot set-at ;
|
||||||
|
|
||||||
M: mirror >alist ( mirror -- alist )
|
M: mirror >alist ( mirror -- alist )
|
||||||
>mirror<
|
[ slots>> [ name>> ] map ]
|
||||||
[ [ slot-spec-offset slot ] with map ] keep
|
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
|
||||||
[ slot-spec-name ] map swap zip ;
|
zip ;
|
||||||
|
|
||||||
M: mirror assoc-size mirror-slots length ;
|
M: mirror assoc-size mirror-slots length ;
|
||||||
|
|
||||||
|
@ -50,7 +49,7 @@ INSTANCE: mirror assoc
|
||||||
|
|
||||||
: sort-assoc ( assoc -- alist )
|
: sort-assoc ( assoc -- alist )
|
||||||
>alist
|
>alist
|
||||||
[ dup first unparse-short swap ] { } map>assoc
|
[ [ first unparse-short ] keep ] { } map>assoc
|
||||||
sort-keys values ;
|
sort-keys values ;
|
||||||
|
|
||||||
GENERIC: make-mirror ( obj -- assoc )
|
GENERIC: make-mirror ( obj -- assoc )
|
||||||
|
|
|
@ -0,0 +1,7 @@
|
||||||
|
USING: kernel sequences math.functions math ;
|
||||||
|
IN: project-euler.100
|
||||||
|
|
||||||
|
: euler100 ( -- n )
|
||||||
|
1 1
|
||||||
|
[ dup dup 1- * 2 * 10 24 ^ <= ]
|
||||||
|
[ tuck 6 * swap - 2 - ] [ ] while nip ;
|
|
@ -0,0 +1,40 @@
|
||||||
|
! Copyright (c) 2008 Eric Mertens
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: sequences combinators kernel sequences.lib math assocs namespaces ;
|
||||||
|
IN: project-euler.151
|
||||||
|
|
||||||
|
SYMBOL: table
|
||||||
|
|
||||||
|
: (pick-sheet) ( seq i -- newseq )
|
||||||
|
[
|
||||||
|
<=> sgn
|
||||||
|
{
|
||||||
|
{ -1 [ ] }
|
||||||
|
{ 0 [ 1- ] }
|
||||||
|
{ 1 [ 1+ ] }
|
||||||
|
} case
|
||||||
|
] curry map-index ;
|
||||||
|
|
||||||
|
DEFER: (euler151)
|
||||||
|
|
||||||
|
: pick-sheet ( seq i -- res )
|
||||||
|
2dup swap nth dup zero? [
|
||||||
|
3drop 0
|
||||||
|
] [
|
||||||
|
[ (pick-sheet) (euler151) ] dip *
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: (euler151) ( x -- y )
|
||||||
|
table get [ {
|
||||||
|
{ { 0 0 0 1 } [ 0 ] }
|
||||||
|
{ { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
|
||||||
|
{ { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
|
||||||
|
{ { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
|
||||||
|
[ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
|
||||||
|
} case ] cache ;
|
||||||
|
|
||||||
|
: euler151 ( -- n )
|
||||||
|
[
|
||||||
|
H{ } clone table set
|
||||||
|
{ 1 1 1 1 } (euler151)
|
||||||
|
] with-scope ;
|
|
@ -131,6 +131,10 @@ MACRO: firstn ( n -- )
|
||||||
[ find drop [ head-slice ] when* ] curry
|
[ find drop [ head-slice ] when* ] curry
|
||||||
[ dup ] swap compose keep like ;
|
[ dup ] swap compose keep like ;
|
||||||
|
|
||||||
|
: replicate ( seq quot -- newseq )
|
||||||
|
#! quot: ( -- obj )
|
||||||
|
[ drop ] swap compose map ;
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -236,3 +240,6 @@ PRIVATE>
|
||||||
|
|
||||||
: remove-nth ( seq n -- seq' )
|
: remove-nth ( seq n -- seq' )
|
||||||
cut-slice 1 tail-slice append ;
|
cut-slice 1 tail-slice append ;
|
||||||
|
|
||||||
|
: short ( seq n -- seq n' )
|
||||||
|
over length min ; inline
|
||||||
|
|
Loading…
Reference in New Issue