diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 8bb8b73ea6..206752f7ca 100644 --- a/basis/lists/lists.factor +++ b/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 ; \ No newline at end of file diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor index ed511d70e2..f7ceedd544 100644 --- a/basis/math/floats/env/env-docs.factor +++ b/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? diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index bcaf1d3e6a..c66100f206 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/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 -hash-sets hashtables io.pathnames io.styles kernel make math -math.order math.parser namespaces prettyprint.config +classes.tuple combinators continuations effects fry generic +hash-sets hashtables io.pathnames io.styles kernel lists make +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* + [ + + ] dip pprint-word block> + ] check-recursion ; + : with-extra-nesting-level ( quot -- ) nesting-limit [ dup [ 1 + ] [ f ] if* ] change [ nesting-limit set ] curry finally ; inline diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 747bbf6d0d..76c7c70bbf 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/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." } ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 8b92932adc..a01bc3ff54 100644 --- a/core/classes/algebra/algebra.factor +++ b/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) ] H{ } make ; +: flatten-class ( class -- seq ) + [ (flatten-class) ] { } make members ; diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index 72178f62f2..74c868a17a 100644 --- a/core/classes/builtin/builtin.factor +++ b/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? ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index bc75d45f42..e88ab89c34 100644 --- a/core/classes/classes-docs.factor +++ b/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? diff --git a/core/classes/intersection/intersection-docs.factor b/core/classes/intersection/intersection-docs.factor index 1f14adf345..54e23e7c08 100644 --- a/core/classes/intersection/intersection-docs.factor +++ b/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" } ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 1e423a472f..bd18ca61b6 100644 --- a/core/classes/intersection/intersection.factor +++ b/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 diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 4d98b63367..00904eb8bd 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/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" } ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index d7362c83c1..ec6fc5f76c 100644 --- a/core/classes/tuple/tuple.factor +++ b/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?) { diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor index fa29330c78..d0a684a021 100644 --- a/core/classes/union/union-docs.factor +++ b/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" diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 05bb9bee3d..e7a0acf955 100644 --- a/core/classes/union/union.factor +++ b/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 - [ drop class>type 2^ bitor ] assoc-each ; + flatten-class 0 [ class>type 2^ bitor ] reduce ; : empty-union-predicate-quot ( class -- quot ) drop [ drop f ] ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 1d0bfaa139..ddb8a96aa8 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -81,8 +81,7 @@ C: predicate-engine ] change-at ; : flatten-method ( method class assoc -- ) - over flatten-class keys - [ swap push-method ] 2with with each ; + over flatten-class [ swap push-method ] 2with with each ; : flatten-methods ( assoc -- assoc' ) H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ; diff --git a/extra/project-euler/064/064.factor b/extra/project-euler/064/064.factor new file mode 100644 index 0000000000..3ead2c409a --- /dev/null +++ b/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 + + 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 + ] ; + +: 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 + ] ; + +: 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 ; + + 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>> / + + ; + +:: split ( fr -- k fr' ) + fr n>> sqrt fr a>> + fr b>> / >integer + dup fr n>> swap + fr b>> * fr a>> swap - + fr b>> + + ; + +: pure ( n -- fr ) + 0 1 + ; + +: 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 + ; diff --git a/extra/project-euler/087/087.factor b/extra/project-euler/087/087.factor new file mode 100644 index 0000000000..c20498415c --- /dev/null +++ b/extra/project-euler/087/087.factor @@ -0,0 +1,40 @@ +USING: locals math math.primes sequences math.functions sets kernel ; +IN: project-euler.087 + +> 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 ; diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000000..e1576d3cb1 --- /dev/null +++ b/shell.nix @@ -0,0 +1,27 @@ +{ pkgs ? import {} }: +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 + ]; +})