From 5ca847c3263f93d19af912996db7490188862f7f Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 29 Nov 2008 15:45:00 +0100 Subject: [PATCH 1/8] Emacs factor mode: cycle between source, tests and docs factor files. --- misc/factor.el | 49 ++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 48 insertions(+), 1 deletion(-) diff --git a/misc/factor.el b/misc/factor.el index 2ffabf7de9..f81b1e8f88 100644 --- a/misc/factor.el +++ b/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 ?\]) From f79041545a34e10d94a9cc5ae7dc337d6daddeaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:19:23 -0600 Subject: [PATCH 2/8] New distance word in math.vectors, replaces distance in math.points, more efficient --- basis/math/points/points.factor | 1 - basis/math/vectors/vectors.factor | 3 +++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/math/points/points.factor b/basis/math/points/points.factor index c8654869e2..107e81d51f 100644 --- a/basis/math/points/points.factor +++ b/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 / - ; \ No newline at end of file diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index 01a421b4e7..a6967a7218 100644 --- a/basis/math/vectors/vectors.factor +++ b/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 } ; From 5bc173b9cf294c334bde34ef5d2d055fbd0ad1f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:19:35 -0600 Subject: [PATCH 3/8] Better hints for float array operations --- basis/float-arrays/float-arrays.factor | 47 ++++++++++++++------------ 1 file changed, 26 insertions(+), 21 deletions(-) diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor index ab3eef62a5..9a71fe27d5 100644 --- a/basis/float-arrays/float-arrays.factor +++ b/basis/float-arrays/float-arrays.factor @@ -64,29 +64,29 @@ 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: 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 } ; +HINTS: vneg { array } { float-array } ; +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 } ; -! More rice. Experimental, currently causes a slowdown in raytracer -! for some odd reason. - -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 +114,15 @@ USING: words classes.algebra compiler.tree.propagation.info ; ] each \ norm-sq [ - class>> float-array class<= float object ? + class>> float-array class<= [ float 0. 1/0. [a,b] ] [ object-info ] if ] "outputs" set-word-prop \ v. [ [ class>> float-array class<= ] both? float object ? ] "outputs" set-word-prop + +\ distance [ + [ class>> float-array class<= ] both? + [ float 0. 1/0. [a,b] ] [ object-info ] if +] "outputs" set-word-prop From cbf392c889b054dbbd3cc8303676e0031b4a4242 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:38:27 -0600 Subject: [PATCH 4/8] Use new distance word --- basis/ui/gestures/gestures.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index ffb9795ef8..5faaa93292 100644 --- a/basis/ui/gestures/gestures.factor +++ b/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 -- ? ) { From f6752238732c3d01da1ad4619fe626c4c1f42eeb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:38:43 -0600 Subject: [PATCH 5/8] Minor optimization in unclip-slice --- core/sequences/sequences.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 832de612dd..118969bd3c 100644 --- a/core/sequences/sequences.factor +++ b/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 From ef0ea005da32b16bc919a984580aa269cf499eda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:38:55 -0600 Subject: [PATCH 6/8] New benchmark: nbody from shootout --- extra/benchmark/nbody/nbody.factor | 106 +++++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) create mode 100644 extra/benchmark/nbody/nbody.factor diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor new file mode 100644 index 0000000000..e99b81e87b --- /dev/null +++ b/extra/benchmark/nbody/nbody.factor @@ -0,0 +1,106 @@ +! 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 } ; + +: ( -- body ) body new ; inline + +: ( -- body ) + + F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 } >>location + F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 } days-per-year v*n >>velocity + 9.54791938424326609e-04 solar-mass * >>mass ; + +: ( -- body ) + + F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 } >>location + F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 } days-per-year v*n >>velocity + 2.85885980666130812e-04 solar-mass * >>mass ; + +: ( -- body ) + + F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 } >>location + F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 } days-per-year v*n >>velocity + 4.36624404335156298e-05 solar-mass * >>mass ; + +: ( -- body ) + + F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 } >>location + F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 } days-per-year v*n >>velocity + 5.15138902046611451e-05 solar-mass * >>mass ; + +: ( -- body ) + + solar-mass >>mass + F{ 0 0 0 } >>location + F{ 0 0 0 } >>velocity ; + +: 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 + +: ( -- system ) + [ , , , , , ] { } 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 -- ) + + [ 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 ; From 1f6222ef40796121e2c58e1160c54571ac5f88f4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 10:39:28 -0600 Subject: [PATCH 7/8] Add a main word --- extra/benchmark/nbody/nbody.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index e99b81e87b..601096a6f8 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -102,5 +102,6 @@ HINTS: inertia body ; HINTS: newton's-law body body ; HINTS: nbody fixnum ; -: nbody-main ( -- ) - 1000000 nbody ; +: nbody-main ( -- ) 1000000 nbody ; + +MAIN: nbody-main From 62faf57fd98a2ba5cfaa99f08f04f7a51491c95d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Nov 2008 11:39:57 -0600 Subject: [PATCH 8/8] Clarify docs --- basis/delegate/delegate-docs.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 0d2f94c13d..5a2f4802e9 100644 --- a/basis/delegate/delegate-docs.factor +++ b/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"