Merge remote-tracking branch 'origin' into modern-harvey3

basis/lists/lists.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel locals math
-sequences ;
+parser sequences ;
 IN: lists
 
 ! List Protocol
@@ -102,3 +102,7 @@ INSTANCE: +nil+ list
 GENERIC: >list ( object -- list )
 
 M: list >list ;
+
+M: sequence >list sequence>list ;
+
+SYNTAX: L{ \ } [ sequence>list ] parse-literal ;

basis/math/floats/env/env-docs.factor

@@ -55,11 +55,11 @@ HELP: +denormal-flush+
 { $class-description "This symbol represents the non-IEEE-754-compliant flush-denormals-to-zero " { $link fp-denormal-mode } "." } ;
 
 HELP: fp-exception-flags
-{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $values { "exceptions" { $sequence fp-exception } } }
 { $description "Returns the set of floating-point exception flags that have been raised." } ;
 
 HELP: set-fp-exception-flags
-{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $values { "exceptions" { $sequence fp-exception } } }
 { $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." }
 { $notes "On Intel platforms, the legacy x87 floating-point unit does not support setting exception flags, so this word only clears the x87 exception flags. However, the SSE unit's flags are set as expected." } ;
 
@@ -67,7 +67,7 @@ HELP: clear-fp-exception-flags
 { $description "Clears all of the floating-point exception flags." } ;
 
 HELP: collect-fp-exceptions
-{ $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $values { "quot" quotation } { "exceptions" { $sequence fp-exception } } }
 { $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
 
 { fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
@@ -93,11 +93,11 @@ HELP: with-rounding-mode
 { rounding-mode with-rounding-mode } related-words
 
 HELP: fp-traps
-{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $values { "exceptions" { $sequence fp-exception } } }
 { $description "Returns the set of floating point exceptions with processor traps currently set." } ;
 
 HELP: with-fp-traps
-{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
+{ $values { "exceptions" { $sequence fp-exception } } { "quot" quotation } }
 { $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ;
 
 HELP: without-fp-traps
@@ -107,7 +107,7 @@ HELP: without-fp-traps
 { fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words
 
 HELP: vm-error>exception-flags
-{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" { $sequence fp-exception } } }
 { $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ;
 
 HELP: vm-error-exception-flag?

basis/prettyprint/backend/backend.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
 classes.algebra.private classes.maybe classes.private
-classes.tuple combinators continuations effects generic
+classes.tuple combinators continuations effects fry generic
-hash-sets hashtables io.pathnames io.styles kernel make math
+hash-sets hashtables io.pathnames io.styles kernel lists make
-math.order math.parser namespaces prettyprint.config
+math math.order math.parser namespaces prettyprint.config
 prettyprint.custom prettyprint.sections prettyprint.stylesheet
 quotations sbufs sequences strings vectors words ;
 QUALIFIED: sets
@@ -214,6 +214,7 @@ M: array pprint-delims drop \ \{ \ \} ;
 M: byte-array pprint-delims drop \ \B{ \ \} ;
 M: byte-vector pprint-delims drop \ \BV{ \ \} ;
 M: vector pprint-delims drop \ \V{ \ \} ;
+M: cons-state pprint-delims drop \ \L{ \ \} ;
 M: hashtable pprint-delims drop \ \H{ \ \} ;
 M: tuple pprint-delims drop \ \T{ \ \} ;
 M: wrapper pprint-delims drop \ \W{ \ \} ;
@@ -265,6 +266,23 @@ M: object pprint* pprint-object ;
 M: vector pprint* pprint-object ;
 M: byte-vector pprint* pprint-object ;
 
+M: cons-state pprint*
+    [
+        <flow
+        dup pprint-delims [
+            pprint-word
+            dup pprint-narrow? <inset
+            [
+                building get
+                length-limit get
+                '[ dup cons-state? _ length _ < and ]
+                [ uncons swap , ] while
+            ] { } make
+            [ pprint* ] each nil? [ "~more~" text ] unless
+            block>
+        ] dip pprint-word block>
+    ] check-recursion ;
+
 : with-extra-nesting-level ( quot -- )
     nesting-limit [ dup [ 1 + ] [ f ] if* ] change
     [ nesting-limit set ] curry finally ; inline

core/classes/algebra/algebra-docs.factor

@@ -41,11 +41,11 @@ $nl
 { $subsections rank-class } ;
 
 HELP: flatten-class
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
+{ $values { "class" class } { "seq" { $sequence class } } }
 { $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
 
 HELP: class<=
-{ $values { "first" "a class" } { "second" "a class" } { "?" boolean } }
+{ $values { "first" class } { "second" class } { "?" boolean } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 <= class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 
@@ -74,5 +74,5 @@ HELP: smallest-class
 { $description "Outputs a minimum class from the given sequence." } ;
 
 HELP: sort-classes
-{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } }
+{ $values { "seq" { $sequence class } } { "newseq" { $sequence class } } }
 { $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;

core/classes/algebra/algebra.factor

@@ -288,5 +288,5 @@ ERROR: topological-sort-failed ;
         [ ] [ [ class<= ] most ] map-reduce
     ] if-empty ;
 
-: flatten-class ( class -- assoc )
+: flatten-class ( class -- seq )
-    [ (flatten-class) ] H{ } make ;
+    [ (flatten-class) ] { } make members ;

core/classes/builtin/builtin.factor

@@ -26,7 +26,7 @@ M: builtin-class rank-class drop 0 ;
 
 M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
 
-M: builtin-class (flatten-class) dup ,, ;
+M: builtin-class (flatten-class) , ;
 
 M: builtin-class (classes-intersect?) eq? ;
 

core/classes/classes-docs.factor

@@ -87,7 +87,7 @@ HELP: class-usage
 { $description "Lists all classes that uses or depends on this class." } ;
 
 HELP: classes
-{ $values { "seq" "a sequence of class words" } }
+{ $values { "seq" { $sequence class } } }
 { $description "Finds all class words in the dictionary." } ;
 
 HELP: contained-classes
@@ -166,12 +166,12 @@ HELP: class-participants
 { $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
 
 HELP: define-class
-{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
+{ $values { "word" word } { "superclass" class } { "members" { $sequence class } } { "participants" { $sequence class } } { "metaclass" class } }
 { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
 $low-level-note ;
 
 HELP: implementors
-{ $values { "class/classes" "a class or a sequence of classes" } { "seq" "a sequence of generic words" } }
+{ $values { "class/classes" { $or class { $sequence class } } } { "seq" "a sequence of generic words" } }
 { $description "Finds all generic words in the dictionary implementing methods for the given set of classes." } ;
 
 HELP: instance?

core/classes/intersection/intersection-docs.factor

@@ -19,7 +19,7 @@ ARTICLE: "intersections" "Intersection classes"
 ABOUT: "intersections"
 
 HELP: define-intersection-class
-{ $values { "class" class } { "participants" "a sequence of classes" } }
+{ $values { "class" class } { "participants" { $sequence class } } }
 { $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link \ \INTERSECTION: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "class" } ;

core/classes/intersection/intersection.factor

@@ -46,9 +46,9 @@ M: intersection-class (flatten-class)
 
 M: anonymous-intersection (flatten-class)
     participants>> [ full-cover ] [
-        [ flatten-class keys ]
+        [ flatten-class ]
         [ intersect-flattened-classes ] map-reduce
-        [ dup ,, ] each
+        %
     ] if-empty ;
 
 M: anonymous-intersection class-name

core/classes/tuple/tuple-docs.factor

@@ -373,7 +373,7 @@ HELP: define-tuple-predicate
 $low-level-note ;
 
 HELP: redefine-tuple-class
-{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $values { "class" class } { "superclass" class } { "slots" { $sequence string } } }
 { $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
 $nl
 "If the class is not a tuple class word, this word does nothing." }
@@ -396,7 +396,7 @@ HELP: check-tuple
 { $error-description "Thrown if " { $link \ \C: } " is called with a word which does not name a tuple class." } ;
 
 HELP: define-tuple-class
-{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $values { "class" word } { "superclass" class } { "slots" { $sequence string } } }
 { $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link \ \TUPLE: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "class" } ;

core/classes/tuple/tuple.factor

@@ -358,7 +358,7 @@ M: tuple-class rank-class drop 1 ;
 M: tuple-class instance?
     dup echelon-of layout-class-offset tuple-instance? ;
 
-M: tuple-class (flatten-class) dup ,, ;
+M: tuple-class (flatten-class) , ;
 
 M: tuple-class (classes-intersect?)
     {

core/classes/union/union-docs.factor

@@ -21,12 +21,12 @@ ARTICLE: "unions" "Union classes"
 ABOUT: "unions"
 
 HELP: (define-union-class)
-{ $values { "class" class } { "members" "a sequence of classes" } }
+{ $values { "class" class } { "members" { $sequence class } } }
 { $description "Defines a union class." }
 { $errors "Throws " { $link cannot-reference-self } " if the definition references itself." } ;
 
 HELP: define-union-class
-{ $values { "class" class } { "members" "a sequence of classes" } }
+{ $values { "class" class } { "members" { $sequence class } } }
 { $description "Defines a union class with specified members. This is the run time equivalent of " { $link \ \UNION: } "." }
 { $notes "This word must be called from inside " { $link with-compilation-unit } "." }
 { $side-effects "class"

core/classes/union/union.factor

@@ -22,8 +22,7 @@ M: class union-of-builtins?
     drop f ;
 
 : fast-union-mask ( class -- n )
-    [ 0 ] dip flatten-class
+    flatten-class 0 [ class>type 2^ bitor ] reduce ;
-    [ drop class>type 2^ bitor ] assoc-each ;
 
 : empty-union-predicate-quot ( class -- quot )
     drop [ drop f ] ;

core/generic/single/single.factor

@@ -81,8 +81,7 @@ C: <predicate-engine> predicate-engine
     ] change-at ;
 
 : flatten-method ( method class assoc -- )
-    over flatten-class keys
+    over flatten-class [ swap push-method ] 2with with each ;
-    [ swap push-method ] 2with with each ;
 
 : flatten-methods ( assoc -- assoc' )
     H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;

extra/project-euler/064/064.factor

@@ -0,0 +1,132 @@
+USING: accessors arrays classes.tuple io kernel locals math math.functions
+    math.ranges prettyprint project-euler.common sequences ;
+IN: project-euler.064
+
+<PRIVATE
+
+TUPLE: cont-frac
+    { whole integer }
+    { num-const integer }
+    { denom integer } ;
+
+C: <cont-frac> cont-frac
+
+: deep-copy ( cont-frac -- cont-frac cont-frac )
+    dup tuple>array rest cont-frac slots>tuple ;
+
+: create-cont-frac ( n -- n cont-frac )
+    dup sqrt >fixnum
+    [let :> root
+        root
+        root
+        1
+    ] <cont-frac> ;
+
+: step ( n cont-frac -- n cont-frac )
+    swap dup
+    ! Store n
+    [let :> n
+        ! Extract the constant
+        swap dup num-const>>
+        :> num-const
+
+        ! Find the new denominator
+        num-const 2 ^ n swap -
+        :> exp-denom
+
+        ! Find the fraction in lowest terms
+        dup denom>>
+        exp-denom simple-gcd
+        exp-denom swap /
+        :> new-denom
+
+        ! Find the new whole number
+        num-const n sqrt + new-denom / >fixnum
+        :> new-whole
+
+        ! Find the new num-const
+        num-const new-denom /
+        new-whole swap -
+        new-denom *
+        :> new-num-const
+
+        ! Finally, update the continuing fraction
+        drop new-whole new-num-const new-denom <cont-frac>
+    ] ;
+
+: loop ( c l n cont-frac -- c l n cont-frac )
+    [let :> cf :> n :> l :> c
+        n cf step
+        :> new-cf drop
+        c 1 + l n new-cf
+        l new-cf = [ ] [ loop ] if
+    ] ;
+
+: find-period ( n -- period )
+    0 swap
+    create-cont-frac
+    step
+    deep-copy -rot
+    loop
+    drop drop drop ;
+
+: try-all ( -- n ) 2 10000 [a,b]
+    [ perfect-square? not ] filter
+    [ find-period ] map
+    [ odd? ] filter
+    length ;
+
+PRIVATE>
+
+: euler064a ( -- n ) try-all ;
+
+<PRIVATE
+! (√n + a)/b
+TUPLE: cfrac n a b ;
+
+C: <cfrac> cfrac
+
+! (√n + a) / b = 1 / (k + (√n + a') / b')
+!
+! b / (√n + a) = b (√n - a) / (n - a^2) = (√n - a) / ((n - a^2) / b)
+:: reciprocal ( fr -- fr' )
+    fr n>>
+    fr a>> neg
+    fr n>> fr a>> sq - fr b>> /
+    <cfrac>
+    ;
+
+:: split ( fr -- k fr' )
+    fr n>> sqrt fr a>> + fr b>> / >integer
+    dup fr n>> swap
+    fr b>> * fr a>> swap -
+    fr b>>
+    <cfrac>
+    ;
+
+: pure ( n -- fr )
+    0 1 <cfrac>
+    ;
+
+: next ( fr -- fr' )
+    reciprocal split nip
+    ;
+
+:: period ( n -- per )
+    n pure split nip :> start
+    n sqrt >integer sq n =
+    [ 0 ]
+    [ 1 start next
+      [ dup start = not ]
+      [ next [ 1 + ] dip ]
+      while
+      drop
+    ] if
+    ;
+
+PRIVATE>
+
+: euler064b ( -- ct )
+    1 10000 [a,b]
+    [ period odd? ] count
+    ;

extra/project-euler/087/087.factor

@@ -0,0 +1,40 @@
+USING: locals math math.primes sequences math.functions sets kernel ;
+IN: project-euler.087
+
+<PRIVATE
+
+: remove-duplicates ( seq -- seq' )
+    dup intersect ;
+
+:: prime-powers-less-than ( primes pow n -- prime-powers )
+    primes [ pow ^ ] map [ n <= ] filter ;
+
+! You may think to make a set of all possible sums of a prime square and cube 
+! and then subtract prime fourths from numbers ranging from 1 to 'n' to find 
+! this. As n grows large, this is actually more inefficient!
+! Prime numbers grow ~ n / log n
+! Thus there are (n / log n)^(1/2) prime squares <= n,
+!                (n / log n)^(1/3) prime cubes   <= n,
+!            and (n / log n)^(1/4) prime fourths <= n.
+! If we compute the cartesian product of these, this takes 
+! O((n / log n)^(13/12)).
+! If we instead precompute sums of squares and cubes, and iterate up to n,
+! checking each fourth power against it, this takes
+! O(n * (n / log n)^(1/4)) = O(n^(5/4)/(log n)^(1/4)) >> O((n / log n)^(13/12))
+!
+! When n = 50000000, the first equation is approximately 10 million and 
+! the second is approximately 2 billion.
+
+:: prime-triples ( n -- answer )
+    n sqrt primes-upto                :> primes
+    primes 2 n prime-powers-less-than :> primes^2
+    primes 3 n prime-powers-less-than :> primes^3
+    primes 4 n prime-powers-less-than :> primes^4
+    primes^2 primes^3 [ + ] cartesian-map concat
+             primes^4 [ + ] cartesian-map concat
+    [ n <= ] filter remove-duplicates length ;
+
+PRIVATE>
+
+:: euler087 ( -- answer )
+    50000000 prime-triples ;

shell.nix

@@ -0,0 +1,27 @@
+{ pkgs ? import <nixpkgs> {} }:
+with pkgs;
+let
+  mkClangShell = mkShell.override { stdenv = clangStdenv; };
+  runtimeLibs = with xorg; [
+    glib
+    pango cairo
+    gtk2-x11
+    gdk_pixbuf
+    gnome2.gtkglext
+    pcre
+    mesa_glu
+    freealut
+    openssl
+    udis86 # available since NixOS 19.09
+    openal
+  ];
+in
+(mkClangShell {
+  name = "factor-shell-env";
+  LD_LIBRARY_PATH = "/run/opengl-driver/lib:${lib.makeLibraryPath runtimeLibs}" ;
+  buildInputs = runtimeLibs ++ [
+    # for building factor
+    git
+    curl
+  ];
+})