Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-04-24 23:42:50 -05:00
commit 2f103f19ea
7 changed files with 86 additions and 21 deletions

View File

@ -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 ( -- )

View File

@ -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." } ;

View File

@ -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

View File

@ -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 )

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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