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

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" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/mirrors/mirrors-docs.factor

@@ -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
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

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> foo
 [ 3 ] [
     3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
 ] 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

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 ;
 : <mirror> ( 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 )

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 ;

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 ;

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 ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 <PRIVATE
@@ -236,3 +240,6 @@ PRIVATE>
 
 : remove-nth ( seq n -- seq' )
     cut-slice 1 tail-slice append ;
+
+: short ( seq n -- seq n' )
+    over length min ; inline