diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 827a5c4e8d..f2740a63a9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser classes.tuple continuations continuations.private combinators generic.math io.streams.duplex classes.builtin classes 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 GENERIC: error. ( error -- ) @@ -289,6 +289,10 @@ M: encode-error summary drop "Character encoding 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" ; + } } ; -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 { $values { "obj" object } { "assoc" assoc } } { $description "Creates an assoc which reflects the internal structure of the object." } ; diff --git a/core/mirrors/mirrors-tests.factor b/core/mirrors/mirrors-tests.factor index 11e5772000..45970c8bae 100755 --- a/core/mirrors/mirrors-tests.factor +++ b/core/mirrors/mirrors-tests.factor @@ -1,4 +1,4 @@ -USING: mirrors tools.test assocs kernel arrays ; +USING: mirrors tools.test assocs kernel arrays accessors ; IN: mirrors.tests TUPLE: foo bar baz ; @@ -14,3 +14,15 @@ C: foo [ 3 ] [ 3 "baz" 1 2 [ set-at ] keep foo-baz ] unit-test + +[ 3 "hi" 1 2 set-at ] [ + [ no-such-slot? ] + [ name>> "hi" = ] + [ object>> foo? ] tri and and +] must-fail-with + +[ 3 "numerator" 1/2 set-at ] [ + [ immutable-slot? ] + [ name>> "numerator" = ] + [ object>> 1/2 = ] tri and and +] must-fail-with diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 02afaf07fc..0a49163075 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple math vectors -quotations sorting prettyprint ; +quotations sorting prettyprint accessors ; IN: mirrors : all-slots ( class -- slots ) @@ -16,33 +16,32 @@ TUPLE: mirror object slots ; : ( object -- mirror ) dup object-slots mirror boa ; -: >mirror< ( mirror -- obj slots ) - dup mirror-object swap mirror-slots ; +ERROR: no-such-slot object name ; -: mirror@ ( slot-name mirror -- obj slot-spec ) - >mirror< swapd slot-named ; +ERROR: immutable-slot object name ; 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 -- ) - mirror@ dup [ - dup slot-spec-writer [ - slot-spec-offset set-slot + [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [ + dup writer>> [ + nip offset>> set-slot ] [ - "Immutable slot" throw + drop immutable-slot ] if ] [ - "No such slot" throw + drop no-such-slot ] if ; M: mirror delete-at ( key mirror -- ) f -rot set-at ; M: mirror >alist ( mirror -- alist ) - >mirror< - [ [ slot-spec-offset slot ] with map ] keep - [ slot-spec-name ] map swap zip ; + [ slots>> [ name>> ] map ] + [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi + zip ; M: mirror assoc-size mirror-slots length ; @@ -50,7 +49,7 @@ INSTANCE: mirror assoc : sort-assoc ( assoc -- alist ) >alist - [ dup first unparse-short swap ] { } map>assoc + [ [ first unparse-short ] keep ] { } map>assoc sort-keys values ; GENERIC: make-mirror ( obj -- assoc ) diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor new file mode 100644 index 0000000000..d2d396a0e1 --- /dev/null +++ b/extra/project-euler/100/100.factor @@ -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 ; diff --git a/extra/project-euler/151/151.factor b/extra/project-euler/151/151.factor new file mode 100644 index 0000000000..85aad116b4 --- /dev/null +++ b/extra/project-euler/151/151.factor @@ -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 ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index b186ee7777..fe2c660d54 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -131,6 +131,10 @@ MACRO: firstn ( n -- ) [ find drop [ head-slice ] when* ] curry [ dup ] swap compose keep like ; +: replicate ( seq quot -- newseq ) + #! quot: ( -- obj ) + [ drop ] swap compose map ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : remove-nth ( seq n -- seq' ) cut-slice 1 tail-slice append ; + +: short ( seq n -- seq n' ) + over length min ; inline