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

basis/delegate/delegate-docs.factor

@@ -28,21 +28,21 @@ HELP: group-words
 { $values { "group" "a group" } { "words" "an array of words" } }
 { $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
 
-ARTICLE: { "delegate" "intro" } "Delegation"
+ARTICLE: "delegate" "Delegation"
 "The " { $vocab-link "delegate" } " vocabulary implements run-time consultation for method dispatch."
 $nl
-"Fundamental to the concept of " { $emphasis "protocols" } ", which are groups of tuple slot accessors, or groups of arbtirary generic words."
+"A " { $emphasis "protocol" } " is a collection of related generic words. An object is said to " { $emphasis "consult" } " another object if it implements a protocol by forwarding all methods onto the other object."
 $nl
-"This allows an object to implement a certain protocol by passing the method calls to another object."
+"Using this vocabulary, protocols can be defined and consulation can be set up without any repetitive boilerplate."
 $nl
 "Unlike " { $link "tuple-subclassing" } ", which expresses " { $emphasis "is-a" } " relationships by statically including the methods and slots of the superclass in all subclasses, consultation forwards generic word calls to another distinct object."
 $nl
-"Fundamentally, a protocol is a word which has a method for " { $link group-words } ". One type of protocol is a tuple, which consists of the slot accessors. To define a protocol as a set of words, use"
+"Defining new protocols:"
 { $subsection POSTPONE: PROTOCOL: }
 { $subsection define-protocol }
-"The literal syntax and defining word are:"
+"Defining consultation:"
 { $subsection POSTPONE: CONSULT: }
 { $subsection define-consult }
-"The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
+"Every tuple class has an associated protocol consisting of all of its slot accessor methods. The " { $vocab-link "delegate.protocols" } " vocabulary defines formal protocols for the various informal protocols used in the Factor core, such as " { $link "sequence-protocol" } ", " { $link "assocs-protocol" } " or " { $link "stream-protocol" } ;
 
-ABOUT: { "delegate" "intro" }
+ABOUT: "delegate"

basis/float-arrays/float-arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private alien.accessors sequences
 sequences.private math math.private byte-arrays accessors
-alien.c-types parser prettyprint.backend ;
+alien.c-types parser prettyprint.backend combinators ;
 IN: float-arrays
 
 TUPLE: float-array
@@ -64,29 +64,31 @@ M: float-array pprint-delims drop \ F{ \ } ;
 M: float-array >pprint-sequence ;
 M: float-array pprint* pprint-object ;
 
-! Rice
+! Specializer hints
 USING: hints math.vectors arrays ;
 
-HINTS: vneg { float-array } { array } ;
+HINTS: <float-array> { 2 } { 3 } ;
-HINTS: v*n { float-array float } { array object } ;
-HINTS: n*v { float float-array } { array object } ;
-HINTS: v/n { float-array float } { array object } ;
-HINTS: n/v { float float-array } { object array } ;
-HINTS: v+ { float-array float-array } { array array } ;
-HINTS: v- { float-array float-array } { array array } ;
-HINTS: v* { float-array float-array } { array array } ;
-HINTS: v/ { float-array float-array } { array array } ;
-HINTS: vmax { float-array float-array } { array array } ;
-HINTS: vmin { float-array float-array } { array array } ;
-HINTS: v. { float-array float-array } { array array } ;
-HINTS: norm-sq { float-array } { array } ;
-HINTS: norm { float-array } { array } ;
-HINTS: normalize { float-array } { array } ;
 
-! More rice. Experimental, currently causes a slowdown in raytracer
+HINTS: vneg { array } { float-array } ;
-! for some odd reason.
+HINTS: v*n { array object } { float-array float } ;
+HINTS: n*v { array object } { float float-array } ;
+HINTS: v/n { array object } { float-array float } ;
+HINTS: n/v { object array } { float float-array } ;
+HINTS: v+ { array array } { float-array float-array } ;
+HINTS: v- { array array } { float-array float-array } ;
+HINTS: v* { array array } { float-array float-array } ;
+HINTS: v/ { array array } { float-array float-array } ;
+HINTS: vmax { array array } { float-array float-array } ;
+HINTS: vmin { array array } { float-array float-array } ;
+HINTS: v. { array array } { float-array float-array } ;
+HINTS: norm-sq { array } { float-array } ;
+HINTS: norm { array } { float-array } ;
+HINTS: normalize { array } { float-array } ;
+HINTS: distance { array array } { float-array float-array } ;
 
-USING: words classes.algebra compiler.tree.propagation.info ;
+! Type functions
+USING: words classes.algebra compiler.tree.propagation.info
+math.intervals ;
 
 { v+ v- v* v/ vmax vmin } [
     [
@@ -114,10 +116,15 @@ USING: words classes.algebra compiler.tree.propagation.info ;
 ] each
 
 \ norm-sq [
-    class>> float-array class<= float object ? <class-info>
+    class>> float-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
 ] "outputs" set-word-prop
 
 \ v. [
     [ class>> float-array class<= ] both?
     float object ? <class-info>
 ] "outputs" set-word-prop
+
+\ distance [
+    [ class>> float-array class<= ] both?
+    [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
+] "outputs" set-word-prop

basis/hints/hints-docs.factor

@@ -1,10 +1,10 @@
 IN: hints
-USING: help.markup help.syntax words quotations sequences ;
+USING: help.markup help.syntax words quotations sequences kernel ;
 
 ARTICLE: "hints" "Compiler specialization hints"
 "Specialization hints help the compiler generate efficient code."
 $nl
-"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class, or even " { $link eq? } " to some literal. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class or value, and inlining of generic methods can take place."
 $nl
 "Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
 $nl
@@ -20,10 +20,10 @@ HELP: specialized-def
 { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
 
 HELP: HINTS:
-{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
+{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
 { $description "Defines specialization hints for a word or a method."
 $nl
-"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
+"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
 { $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
 { $code "HINTS: append { string string } { array array } ;" }
 "Specializers can also be defined on methods:"

basis/hints/hints.factor

@@ -3,25 +3,34 @@
 USING: parser words definitions kernel sequences assocs arrays
 kernel.private fry combinators accessors vectors strings sbufs
 byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines ;
+math generic generic.standard generic.standard.engines classes ;
 IN: hints
 
-: (make-specializer) ( class picker -- quot )
+GENERIC: specializer-predicate ( spec -- quot )
-    swap "predicate" word-prop append ;
 
-: make-specializer ( classes -- quot )
+M: class specializer-predicate "predicate" word-prop ;
+
+M: object specializer-predicate '[ _ eq? ] ;
+
+GENERIC: specializer-declaration ( spec -- class )
+
+M: class specializer-declaration ;
+
+M: object specializer-declaration class ;
+
+: make-specializer ( specs -- quot )
     dup length <reversed>
     [ (picker) 2array ] 2map
     [ drop object eq? not ] assoc-filter
     [ [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
+        [ swap specializer-predicate append ] { } assoc>map
         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
     ] if-empty ;
 
 : specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
-        '[ _ declare ] pick append
+        [ specializer-declaration ] map '[ _ declare ] pick append
     ] { } map>assoc ;
 
 : method-declaration ( method -- quot )

basis/math/points/points.factor

@@ -22,6 +22,5 @@ PRIVATE>
 : rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
 : run ( pt2 pt1 -- n ) [ first ] bi@ - ;
 : slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
-: distance ( point point -- float ) v- norm ;
 : midpoint ( point point -- point ) v+ 2 v/n ;
 : linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;

basis/math/vectors/vectors.factor

@@ -24,6 +24,8 @@ IN: math.vectors
 : norm ( v -- x ) norm-sq sqrt ;
 : normalize ( u -- v ) dup norm v/n ;
 
+: distance ( u v -- x ) [ - absq ] [ + ] 2map-reduce sqrt ;
+
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
@@ -31,6 +33,7 @@ HINTS: vneg { array } ;
 HINTS: norm-sq { array } ;
 HINTS: norm { array } ;
 HINTS: normalize { array } ;
+HINTS: distance { array array } ;
 
 HINTS: n*v { object array } ;
 HINTS: v*n { array object } ;

basis/stack-checker/backend/backend.factor

@@ -4,7 +4,7 @@ USING: fry arrays generic io io.streams.string kernel math
 namespaces parser prettyprint sequences strings vectors words
 quotations effects classes continuations debugger assocs
 combinators compiler.errors accessors math.order definitions
-sets generic.standard.engines.tuple stack-checker.state
+sets generic.standard.engines.tuple hints stack-checker.state
 stack-checker.visitor stack-checker.errors
 stack-checker.values stack-checker.recursive-state ;
 IN: stack-checker.backend
@@ -125,7 +125,7 @@ M: object apply-object push-literal ;
     ] 2bi ; inline
 
 : infer-word-def ( word -- )
-    [ def>> ] [ add-recursive-state ] bi infer-quot ;
+    [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 
 : check->r ( -- )
     meta-r get empty? terminated? get or

basis/stack-checker/inlining/inlining.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces assocs kernel sequences words accessors
 definitions math math.order effects classes arrays combinators
-vectors arrays
+vectors arrays hints
 stack-checker.state
 stack-checker.errors
 stack-checker.values
@@ -17,7 +17,7 @@ IN: stack-checker.inlining
 ! having to handle recursive inline words.
 
 : infer-inline-word-def ( word label -- )
-    [ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
+    [ drop specialized-def ] [ add-inline-word ] 2bi infer-quot ;
 
 TUPLE: inline-recursive < identity-tuple
 id

basis/ui/gestures/gestures.factor

@@ -205,7 +205,7 @@ SYMBOL: drag-timer
     dup hand-last-button get = ;
 
 : multi-click-position? ( -- ? )
-    hand-loc get hand-click-loc get v- norm-sq 100 <= ;
+    hand-loc get hand-click-loc get distance 10 <= ;
 
 : multi-click? ( button -- ? )
     {

core/math/floats/floats-tests.factor

@@ -60,3 +60,5 @@ unit-test
 [ 0 ] [ 1/0. >bignum ] unit-test
 
 [ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
+
+[ 5 ] [ 10.5 1.9 /i ] unit-test

core/math/floats/floats.factor

@@ -24,6 +24,7 @@ M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
 M: float /f float/f ;
+M: float /i float/f >integer ;
 M: float mod float-mod ;
 
 M: real abs dup 0 < [ neg ] when ;

core/sequences/sequences.factor

@@ -101,14 +101,17 @@ M: integer nth-unsafe drop ;
 
 INSTANCE: integer immutable-sequence
 
+: first-unsafe
+    0 swap nth-unsafe ; inline
+
 : first2-unsafe
-    [ 0 swap nth-unsafe 1 ] [ nth-unsafe ] bi ; inline
+    [ first-unsafe ] [ 1 swap nth-unsafe ] bi ; inline
 
 : first3-unsafe
-    [ first2-unsafe 2 ] [ nth-unsafe ] bi ; inline
+    [ first2-unsafe ] [ 2 swap nth-unsafe ] bi ; inline
 
 : first4-unsafe
-    [ first3-unsafe 3 ] [ nth-unsafe ] bi ; inline
+    [ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
 
 : exchange-unsafe ( m n seq -- )
     [ tuck [ nth-unsafe ] 2bi@ ]
@@ -774,13 +777,13 @@ PRIVATE>
     tuck [ tail-slice ] 2bi@ ;
 
 : unclip ( seq -- rest first )
-    [ rest ] [ first ] bi ;
+    [ rest ] [ first-unsafe ] bi ;
 
 : unclip-last ( seq -- butlast last )
     [ but-last ] [ peek ] bi ;
 
 : unclip-slice ( seq -- rest-slice first )
-    [ rest-slice ] [ first ] bi ; inline
+    [ rest-slice ] [ first-unsafe ] bi ; inline
 
 : 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
     [ unclip-slice ] bi@ swapd ; inline

extra/benchmark/nbody/nbody.factor

@@ -0,0 +1,105 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors float-arrays fry kernel locals make math
+math.constants math.functions math.vectors prettyprint
+sequences hints arrays ;
+IN: benchmark.nbody
+
+: solar-mass 4 pi sq * ; inline
+: days-per-year 365.24 ; inline
+
+TUPLE: body
+{ location float-array }
+{ velocity float-array }
+{ mass float read-only } ;
+
+: <body> ( location velocity mass -- body )
+    [ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline
+
+: <jupiter> ( -- body )
+    F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 }
+    F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 }
+    9.54791938424326609e-04
+    <body> ;
+
+: <saturn> ( -- body )
+    F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 }
+    F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 }
+    2.85885980666130812e-04
+    <body> ;
+
+: <uranus> ( -- body )
+    F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 }
+    F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 }
+    4.36624404335156298e-05
+    <body> ;
+
+: <neptune> ( -- body )
+    F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 }
+    F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 }
+    5.15138902046611451e-05
+    <body> ;
+
+: <sun> ( -- body )
+    F{ 0 0 0 } F{ 0 0 0 } 1 <body> ;
+    
+: offset-momentum ( body offset -- body )
+    vneg solar-mass v/n >>velocity ; inline
+
+TUPLE: nbody-system { bodies array read-only } ;
+
+: init-bodies ( bodies -- )
+    [ first ] [ F{ 0 0 0 } [ [ velocity>> ] [ mass>> ] bi v*n v+ ] reduce ] bi
+    offset-momentum drop ; inline
+
+: <nbody-system> ( -- system )
+    [ <sun> , <jupiter> , <saturn> , <uranus> , <neptune> , ] { } make nbody-system boa
+    dup bodies>> init-bodies ; inline
+
+:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+    bodies [| body i |
+        body each-quot call
+        bodies i 1+ tail-slice [
+            body pair-quot call
+        ] each
+    ] each-index ; inline
+
+: update-position ( body dt -- )
+    [ dup velocity>> ] dip '[ _ _ v*n v+ ] change-location drop ;
+
+: mag ( dt body other-body -- mag d )
+    [ location>> ] bi@ v- [ norm-sq dup sqrt * / ] keep ; inline
+
+:: update-velocity ( other-body body dt -- )
+    dt body other-body mag
+    [ [ body ] 2dip '[ other-body mass>> _ * _ n*v v- ] change-velocity drop ]
+    [ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ;
+
+: advance ( system dt -- )
+    [ bodies>> ] dip
+    [ '[ _ update-velocity ] [ drop ] each-pair ]
+    [ '[ _ update-position ] each ]
+    2bi ; inline
+
+: inertia ( body -- e )
+    [ mass>> ] [ velocity>> norm-sq ] bi * 0.5 * ;
+
+: newton's-law ( other-body body -- e )
+    [ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ;
+
+: energy ( system -- x )
+    [ 0.0 ] dip bodies>> [ newton's-law - ] [ inertia + ] each-pair ; inline
+
+: nbody ( n -- )
+    <nbody-system>
+    [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+
+HINTS: update-position body float ;
+HINTS: update-velocity body body float ;
+HINTS: inertia body ;
+HINTS: newton's-law body body ;
+HINTS: nbody fixnum ;
+
+: nbody-main ( -- ) 1000000 nbody ;
+
+MAIN: nbody-main

extra/jamshred/tunnel/tunnel.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USING: accessors arrays colors combinators float-arrays kernel
-USE: tools.walker
+locals math math.constants math.matrices math.order math.ranges
+math.vectors math.quadratic random sequences vectors jamshred.oint ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline

misc/factor.el

@@ -36,6 +36,7 @@
 (require 'font-lock)
 (require 'comint)
 (require 'view)
+(require 'ring)
 
 ;;; Customization:
 
@@ -166,6 +167,15 @@ buffer."
   "Face for headlines in help buffers."
   :group 'factor-faces)
 
+
+;;; Compatibility
+(when (not (fboundp 'ring-member))
+  (defun ring-member (ring item)
+    (catch 'found
+      (dotimes (ind (ring-length ring) nil)
+        (when (equal item (ring-ref ring ind))
+          (throw 'found ind))))))
+
 
 ;;; Factor mode font lock:
 
@@ -625,7 +635,43 @@ buffer."
   (factor--with-vocab vocab
     (factor--listener-send-cmd cmd)))
 
-;;;;; Interface: see
+
+;;;;; Buffer cycling and docs
+
+
+(defconst factor--cycle-endings
+  '(".factor" "-tests.factor" "-docs.factor"))
+
+(defconst factor--regex-cycle-endings
+  (format "\\(.*?\\)\\(%s\\)$"
+          (regexp-opt factor--cycle-endings)))
+
+(defconst factor--cycle-endings-ring
+  (let ((ring (make-ring (length factor--cycle-endings))))
+    (dolist (e factor--cycle-endings ring)
+      (ring-insert ring e))))
+
+(defun factor--cycle-next (file)
+  (let* ((match (string-match factor--regex-cycle-endings file))
+         (base (and match (match-string-no-properties 1 file)))
+         (ending (and match (match-string-no-properties 2 file)))
+         (idx (and ending (ring-member factor--cycle-endings-ring ending)))
+         (gfl (lambda (i) (concat base (ring-ref factor--cycle-endings-ring i)))))
+    (if (not idx) file
+      (let ((l (length factor--cycle-endings)) (i 1) next)
+        (while (and (not next) (< i l))
+          (when (file-exists-p (funcall gfl (+ idx i)))
+            (setq next (+ idx i)))
+          (setq i (1+ i)))
+        (funcall gfl (or next idx))))))
+
+(defun factor-visit-other-file (&optional file)
+  "Cycle between code, tests and docs factor files."
+  (interactive)
+  (find-file (factor--cycle-next (or file (buffer-file-name)))))
+
+
+;;;;; Interface: See
 
 (defconst factor--regex-error-marker "^Type :help for debugging")
 (defconst factor--regex-data-stack "^--- Data stack:")
@@ -848,6 +894,7 @@ vocabularies which have been modified on disk."
 (factor--define-key ?s 'factor-see t)
 (factor--define-key ?e 'factor-edit)
 (factor--define-key ?z 'switch-to-factor t)
+(factor--define-key ?o 'factor-visit-other-file)
 (factor--define-key ?c 'comment-region)
 
 (factor--define-auto-indent-key ?\])