From 90f6fef8d29d587186f23e51c605ddc524026f93 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 27 Dec 2008 15:18:17 +0100 Subject: [PATCH 01/53] FUEL: fix in autodoc require's and echo area font lock. --- extra/fuel/fuel.factor | 4 +--- misc/fuel/fuel-autodoc.el | 6 ++++-- misc/fuel/fuel-eval.el | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 35ca438f31..7f6af22df8 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -99,9 +99,7 @@ M: source-file fuel-pprint path>> fuel-pprint ; clone fuel-eval-result set-global ; inline : fuel-retort ( -- ) - error get - fuel-eval-result get-global - fuel-eval-output get-global + error get fuel-eval-result get-global fuel-eval-output get-global 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ; : fuel-forget-error ( -- ) f error set-global ; inline diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 96c47d2c69..a1c1d19b98 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -15,6 +15,7 @@ ;;; Code: (require 'fuel-eval) +(require 'fuel-font-lock) (require 'fuel-syntax) (require 'fuel-base) @@ -36,6 +37,7 @@ (defvar fuel-autodoc--font-lock-buffer (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) (set-buffer buffer) + (set-syntax-table fuel-syntax--syntax-table) (fuel-font-lock--font-lock-setup) buffer)) @@ -51,8 +53,8 @@ (fuel-log--inhibit-p t)) (when word (let* ((cmd (if (fuel-syntax--in-using) - `(:fuel* (,word fuel-vocab-summary) t t) - `(:fuel* (((:quote ,word) synopsis :get)) t))) + `(:fuel* (,word fuel-vocab-summary) :in t) + `(:fuel* (((:quote ,word) synopsis :get)) :in))) (ret (fuel-eval--send/wait cmd 20)) (res (fuel-eval--retort-result ret))) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 204e794925..078a7005f8 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -67,7 +67,7 @@ (cons :array (mapcar 'factor lst))) (defsubst factor--fuel-in (in) - (cond ((null in) :in) + (cond ((or (eq in :in) (null in)) :in) ((eq in 'f) 'f) ((eq in 't) "fuel-scratchpad") ((stringp in) in) From 308f18b81e9c43bdbe752835068dd4c64ad199a5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 27 Dec 2008 15:44:15 +0100 Subject: [PATCH 02/53] FUEL: Correct syntax identification for CHAR: x forms with x a paren char. --- misc/fuel/fuel-syntax.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index eeca09865d..3778caf832 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -157,14 +157,14 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(("\\_<\\(#?!\\) .*\\(\n\\)" (1 "<") (2 ">")) - ("\\_<\\(#?!\\)\\(\n\\)" (1 "<") (2 ">")) + `(("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) ("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|")) (" \\(|\\) " (1 "(|")) (" \\(|\\)$" (1 ")")) - ("CHAR: \\(\"\\)\\( \\|$\\)" (1 "w")) + ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) (,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}")) ("\\_<\\({\\)\\_>" (1 "(}")) ("\\_<\\(}\\)\\_>" (1 "){")) From ff99bf016d4693c2e54f146997d5516961c0e454 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 27 Dec 2008 17:36:12 +0100 Subject: [PATCH 03/53] FUEL: recognize fried quotations in syntax table. --- misc/fuel/fuel-syntax.el | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 3778caf832..8234f9fcc8 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -157,19 +157,26 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + `(;; Comments: + ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) + ;; CHARs: + ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) + ;; Let and lambda: ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">")) ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]")) ("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|")) (" \\(|\\) " (1 "(|")) (" \\(|\\)$" (1 ")")) - ("CHAR: \\(.\\)\\( \\|$\\)" (1 "w")) + ;; Opening brace words: (,(format "\\_<%s\\({\\)\\_>" (regexp-opt fuel-syntax--bracers)) (1 "(}")) ("\\_<\\({\\)\\_>" (1 "(}")) ("\\_<\\(}\\)\\_>" (1 "){")) + ;; Parenthesis: ("\\_<\\((\\)\\_>" (1 "()")) ("\\_<\\()\\)\\_>" (1 ")(")) + ;; Quotations: + ("\\_<'\\(\\[\\)\\_>" (1 "(]")) ; fried ("\\_<\\(\\[\\)\\_>" (1 "(]")) ("\\_<\\(\\]\\)\\_>" (1 ")[")))) From 0182a3430d00a2746fdd577b3d2345ea6b8b5c5b Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 27 Dec 2008 21:39:32 +0100 Subject: [PATCH 04/53] Allow sigma and friends to use the stack "sigma" used to use the stack to remember the current total. This prevented the use of quotations manipulating elements that were expecting to be on the stack. This patch hides the counter while executing the quotation, so that the latter can fully use the stack. --- core/sequences/sequences.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 31c7c8a4d7..40a8892e8b 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -828,7 +828,7 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline +: sigma ( seq quot -- n ) 0 -rot [ rot slip + ] curry each ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline From 3fbb9f708179acf6f796c0be89062d9118565676 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sat, 27 Dec 2008 21:46:01 +0100 Subject: [PATCH 05/53] Project Euler - problem 57 --- extra/project-euler/057/057.factor | 43 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 14 ++++---- 2 files changed, 50 insertions(+), 7 deletions(-) create mode 100644 extra/project-euler/057/057.factor diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor new file mode 100644 index 0000000000..53240b0ec1 --- /dev/null +++ b/extra/project-euler/057/057.factor @@ -0,0 +1,43 @@ +! Copyright (c) 2008 Samuel Tardieu +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.parser sequences ; +IN: project-euler.057 + +! http://projecteuler.net/index.php?section=problems&id=57 + +! DESCRIPTION +! ----------- + +! It is possible to show that the square root of two can be expressed +! as an infinite continued fraction. + +! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... + +! By expanding this for the first four iterations, we get: + +! 1 + 1/2 = 3/2 = 1.5 +! 1 + 1/(2 + 1/2) = 7/5 = 1.4 +! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... +! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... + +! The next three expansions are 99/70, 239/169, and 577/408, but the +! eighth expansion, 1393/985, is the first example where the number of +! digits in the numerator exceeds the number of digits in the +! denominator. + +! In the first one-thousand expansions, how many fractions contain a +! numerator with more digits than denominator? + +! SOLUTION +! -------- + +: longer-numerator? ( seq -- ? ) + >fraction [ number>string length ] bi@ > ; inline + +: euler057 ( -- answer ) + 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + +! [ euler057 ] time +! 3.375118 seconds + +MAIN: euler057 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index f9fa0f4f18..318cf8a2bb 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -15,13 +15,13 @@ USING: definitions io io.files io.pathnames kernel math math.parser project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.045 project-euler.046 project-euler.047 project-euler.048 project-euler.052 project-euler.053 project-euler.055 project-euler.056 - project-euler.059 project-euler.067 project-euler.071 project-euler.073 - project-euler.075 project-euler.076 project-euler.079 project-euler.092 - project-euler.097 project-euler.099 project-euler.100 project-euler.116 - project-euler.117 project-euler.134 project-euler.148 project-euler.150 - project-euler.151 project-euler.164 project-euler.169 project-euler.173 - project-euler.175 project-euler.186 project-euler.190 project-euler.203 - project-euler.215 ; + project-euler.057 project-euler.059 project-euler.067 project-euler.071 + project-euler.073 project-euler.075 project-euler.076 project-euler.079 + project-euler.092 project-euler.097 project-euler.099 project-euler.100 + project-euler.116 project-euler.117 project-euler.134 project-euler.148 + project-euler.150 project-euler.151 project-euler.164 project-euler.169 + project-euler.173 project-euler.175 project-euler.186 project-euler.190 + project-euler.203 project-euler.215 ; IN: project-euler Date: Sat, 27 Dec 2008 23:13:03 +0100 Subject: [PATCH 06/53] Remove useless with-scope and unneeded uses --- basis/math/miller-rabin/miller-rabin.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 374616ba40..8c237d0dc3 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators io locals kernel math math.functions -math.ranges namespaces random sequences hashtables sets ; +USING: combinators kernel locals math math.functions math.ranges +random sequences sets ; IN: math.miller-rabin { [ dup 1 <= ] [ 3drop f ] } { [ dup 2 = ] [ 3drop t ] } { [ dup even? ] [ 3drop f ] } - [ [ drop (miller-rabin) ] with-scope ] + [ drop (miller-rabin) ] } cond ; : miller-rabin ( n -- ? ) 10 miller-rabin* ; From a843113326ec49f81f6fa7874e21c49a24899ba7 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 28 Dec 2008 11:43:13 +0100 Subject: [PATCH 07/53] Optimize erato sieve We started crossing the numbers at 3*n, while we can start at n^2. --- extra/math/primes/erato/erato.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/primes/erato/erato.factor b/extra/math/primes/erato/erato.factor index f4409038bb..effcd7b135 100644 --- a/extra/math/primes/erato/erato.factor +++ b/extra/math/primes/erato/erato.factor @@ -8,7 +8,7 @@ IN: math.primes.erato 2 * 3 + ; inline : mark-multiples ( i arr -- ) - [ dup index> [ + ] keep ] dip + [ index> [ sq >index ] keep ] dip [ length 1 - swap f swap ] keep [ set-nth ] curry with each ; From ca0f3659e4f7fab7503e6b26c79211245f2b4b8f Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Sun, 28 Dec 2008 11:43:13 +0100 Subject: [PATCH 08/53] Optimize primes-between Rather than having primes-between return a slice of primes-upto, make primes-upto use primes-between. Also, those two words cannot be marked as foldable as their output is mutable. --- extra/math/primes/primes.factor | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor index c8f398863f..fa42d7385a 100644 --- a/extra/math/primes/primes.factor +++ b/extra/math/primes/primes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: binary-search combinators kernel lists.lazy math math.functions -math.miller-rabin math.primes.erato math.ranges sequences ; +USING: combinators kernel lists.lazy math math.functions +math.miller-rabin math.order math.primes.erato math.ranges sequences ; IN: math.primes : lprimes-from ( n -- list ) dup 3 < [ drop lprimes ] [ 1- next-prime [ next-prime ] lfrom-by ] if ; -: primes-upto ( n -- seq ) - dup 2 < [ - drop V{ } - ] [ - 3 swap 2 [ prime? ] filter 2 prefix - ] if ; foldable - : primes-between ( low high -- seq ) - primes-upto [ 1- next-prime ] dip - [ natural-search drop ] [ length ] [ ] tri ; foldable + [ dup 3 max dup even? [ 1 + ] when ] dip + 2 [ prime? ] filter + swap 3 < [ 2 prefix ] when ; + +: primes-upto ( n -- seq ) 2 swap primes-between ; : coprime? ( a b -- ? ) gcd nip 1 = ; foldable From f521805bb3fb8ef3e3bd75242adc4c4e210e740c Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 29 Dec 2008 13:55:47 +0100 Subject: [PATCH 09/53] Memoize small primes list This makes "benchmark.binary-search" work again in a reasonable time. --- extra/math/primes/list/list.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/math/primes/list/list.factor b/extra/math/primes/list/list.factor index 08212840c3..7467d126d0 100644 --- a/extra/math/primes/list/list.factor +++ b/extra/math/primes/list/list.factor @@ -1,4 +1,4 @@ -USING: math.primes ; +USING: math.primes memoize ; IN: math.primes.list -: primes-under-million ( -- seq ) 1000000 primes-upto ; +MEMO: primes-under-million ( -- seq ) 1000000 primes-upto ; From c1c1ebf3d4265e08419720bb6d8c1c4cdb4939f0 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Mon, 29 Dec 2008 21:29:26 +0100 Subject: [PATCH 10/53] Force primes list evaluation before benchmark --- extra/benchmark/binary-search/binary-search.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/benchmark/binary-search/binary-search.factor b/extra/benchmark/binary-search/binary-search.factor index 1018e643ef..e5c81a954d 100644 --- a/extra/benchmark/binary-search/binary-search.factor +++ b/extra/benchmark/binary-search/binary-search.factor @@ -1,10 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: binary-search math.primes.list math.ranges sequences +USING: binary-search kernel math.primes.list math.ranges sequences prettyprint ; IN: benchmark.binary-search : binary-search-benchmark ( -- ) 1 1000000 [a,b] [ primes-under-million sorted-member? ] map length . ; +! Force computation of the primes list before benchmarking the binary search +primes-under-million drop + MAIN: binary-search-benchmark From a0761297ed3c49361e370aa2e647a36784fc7d55 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 00:23:44 +0100 Subject: [PATCH 11/53] FUEL: Increase autodoc timeout. --- extra/fuel/fuel.factor | 13 ++++++------- misc/fuel/fuel-autodoc.el | 13 +++++++++++-- misc/fuel/fuel-help.el | 1 + 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 7f6af22df8..00d9983b46 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -17,13 +17,13 @@ SYMBOL: fuel-status-stack V{ } clone fuel-status-stack set-global SYMBOL: fuel-eval-result -f clone fuel-eval-result set-global +f fuel-eval-result set-global SYMBOL: fuel-eval-output -f clone fuel-eval-result set-global +f fuel-eval-result set-global SYMBOL: fuel-eval-res-flag -t clone fuel-eval-res-flag set-global +t fuel-eval-res-flag set-global : fuel-eval-restartable? ( -- ? ) fuel-eval-res-flag get-global ; inline @@ -105,12 +105,11 @@ M: source-file fuel-pprint path>> fuel-pprint ; : fuel-forget-error ( -- ) f error set-global ; inline : fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline : fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline +: fuel-forget-status ( -- ) + fuel-forget-error fuel-forget-result fuel-forget-output ; inline : (fuel-begin-eval) ( -- ) - fuel-push-status - fuel-forget-error - fuel-forget-result - fuel-forget-output ; + fuel-push-status fuel-forget-status ; inline : (fuel-end-eval) ( output -- ) fuel-eval-output set-global fuel-retort fuel-pop-status ; inline diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index a1c1d19b98..151631eea1 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -31,8 +31,9 @@ :group 'fuel-autodoc :type 'boolean) + -;;; Autodoc mode: +;;; Highlighting for autodoc messages: (defvar fuel-autodoc--font-lock-buffer (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) @@ -48,6 +49,11 @@ (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) (buffer-string)) + +;;; Eldoc function: + +(defvar fuel-autodoc--timeout 200) + (defun fuel-autodoc--word-synopsis (&optional word) (let ((word (or word (fuel-syntax-symbol-at-point))) (fuel-log--inhibit-p t)) @@ -55,7 +61,7 @@ (let* ((cmd (if (fuel-syntax--in-using) `(:fuel* (,word fuel-vocab-summary) :in t) `(:fuel* (((:quote ,word) synopsis :get)) :in))) - (ret (fuel-eval--send/wait cmd 20)) + (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout)) (res (fuel-eval--retort-result ret))) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) (if fuel-autodoc-minibuffer-font-lock @@ -70,6 +76,9 @@ (funcall fuel-autodoc--fallback-function)) (fuel-autodoc--word-synopsis))) + +;;; Autodoc mode: + (make-variable-buffer-local (defvar fuel-autodoc-mode-string " A" "Modeline indicator for fuel-autodoc-mode")) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 9216a9fd02..325e2971be 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -140,6 +140,7 @@ "Notes" "Parent topics:" "See also" + "Side effects" "Syntax" "Variable description" "Variable value" From 5c53e000bcc7145c418cd887137b1690ab3126ac Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 00:31:13 +0100 Subject: [PATCH 12/53] FUEL: Get rid of the USINGs buffer after we're done. --- misc/fuel/fuel-debug-uses.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 127e11d23e..c5c31c8e7d 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -184,7 +184,7 @@ (with-current-buffer (fuel-debug--uses-buffer) (insert "\nDone!") (fuel-debug--uses-clean) - (bury-buffer))))) + (kill-buffer))))) (defun fuel-debug--uses-restart (n) (when (and (> n 0) (<= n (length fuel-debug--uses-restarts))) From e1b661681a339b1f2287644908065431a838fe8f Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 00:39:20 +0100 Subject: [PATCH 13/53] FUEL: New option for no confirmation on restarts (fuel-debug-confirm-restarts-p). --- misc/fuel/fuel-debug.el | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index f376bde1c9..7643d57144 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -31,6 +31,12 @@ :group 'fuel-debug :type 'hook) +(defcustom fuel-debug-confirm-restarts-p t + "Whether to ask for confimation before executing a restart in +the debugger." + :group 'fuel-debug + :type 'boolean) + (defcustom fuel-debug-show-short-help t "Whether to show short help on available keys in debugger." :group 'fuel-debug @@ -241,7 +247,8 @@ (define-key map "p" 'previous-line) (dotimes (n 9) (define-key map (vector (+ ?1 n)) - `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t)))) + `(lambda () (interactive) + (fuel-debug-exec-restart ,(1+ n) fuel-debug-confirm-restarts-p)))) (dolist (ci fuel-debug--compiler-info-alist) (define-key map (vector (cdr ci)) `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci))))) From 33971016c5104457a4b1340a6eb708be8f88c3a9 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 00:47:02 +0100 Subject: [PATCH 14/53] FUEL: Emacs 22 compat. --- misc/fuel/fuel-debug-uses.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index c5c31c8e7d..eecdfa7044 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -184,7 +184,7 @@ (with-current-buffer (fuel-debug--uses-buffer) (insert "\nDone!") (fuel-debug--uses-clean) - (kill-buffer))))) + (kill-buffer (current-buffer)))))) (defun fuel-debug--uses-restart (n) (when (and (> n 0) (<= n (length fuel-debug--uses-restarts))) From a89b5d6a8ac32ffbd31084592acc0347e5587af4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 01:31:03 +0100 Subject: [PATCH 15/53] FUEL: Fix for autodoc in presence of sections. --- misc/fuel/fuel-debug-uses.el | 3 +-- misc/fuel/fuel-syntax.el | 26 ++++++++++---------------- 2 files changed, 11 insertions(+), 18 deletions(-) diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index eecdfa7044..2e94258c28 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -141,8 +141,7 @@ (defun fuel-debug--uses-display (uses) (let* ((inhibit-read-only t) (old (with-current-buffer (find-file-noselect fuel-debug--uses-file) - (fuel-syntax--usings))) - (old (sort old 'string<)) + (sort (fuel-syntax--find-usings t) 'string<))) (new (sort uses 'string<))) (erase-buffer) (fuel-debug--uses-insert-title) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 8234f9fcc8..036ac7cbd0 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -301,21 +301,9 @@ (funcall fuel-syntax--current-vocab-function)) (defun fuel-syntax--find-in () - (let* ((vocab) - (ip - (save-excursion - (when (re-search-backward fuel-syntax--current-vocab-regex nil t) - (setq vocab (match-string-no-properties 1)) - (point))))) - (when ip - (let ((pp (save-excursion - (when (re-search-backward fuel-syntax--sub-vocab-regex ip t) - (point))))) - (when (and pp (> pp ip)) - (let ((sub (match-string-no-properties 1))) - (unless (save-excursion (search-backward (format "%s>" sub) pp t)) - (setq vocab (format "%s.%s" vocab (downcase sub)))))))) - vocab)) + (save-excursion + (when (re-search-backward fuel-syntax--current-vocab-regex nil t) + (match-string-no-properties 1)))) (make-variable-buffer-local (defvar fuel-syntax--usings-function 'fuel-syntax--find-usings)) @@ -323,13 +311,19 @@ (defsubst fuel-syntax--usings () (funcall fuel-syntax--usings-function)) -(defun fuel-syntax--find-usings () +(defun fuel-syntax--find-usings (&optional no-private) (save-excursion (let ((usings)) (goto-char (point-max)) (while (re-search-backward fuel-syntax--using-lines-regex nil t) (dolist (u (split-string (match-string-no-properties 1) nil t)) (push u usings))) + (goto-char (point-min)) + (when (and (not no-private) + (re-search-forward "\\_<" nil t) + (re-search-forward "\\_\\_>" nil t)) + (goto-char (point-max)) + (push (concat (fuel-syntax--find-in) ".private") usings)) usings))) From 303735db5a48b6f5c8c941a8b0d962fdf0eb0b74 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 31 Dec 2008 04:05:34 +0100 Subject: [PATCH 16/53] FUEL: Offer a command to add missing vocabs after run-file. --- extra/fuel/fuel.factor | 15 ++++--- misc/fuel/fuel-debug-uses.el | 69 +++++++------------------------ misc/fuel/fuel-debug.el | 79 ++++++++++++++++++++++++++++++++++-- 3 files changed, 100 insertions(+), 63 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 00d9983b46..c1d90ebbcc 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -135,14 +135,17 @@ M: source-file fuel-pprint path>> fuel-pprint ; ! Loading files -: fuel-run-file ( path -- ) run-file ; inline +SYMBOL: :uses + +: fuel-set-use-hook ( -- ) + [ amended-use get clone :uses prefix fuel-eval-set-result ] + print-use-hook set ; + +: fuel-run-file ( path -- ) + [ fuel-set-use-hook run-file ] curry with-scope ; inline : fuel-with-autouse ( quot -- ) - [ - auto-use? on - [ amended-use get clone fuel-eval-set-result ] print-use-hook set - call - ] curry with-scope ; + [ auto-use? on fuel-set-use-hook call ] curry with-scope ; : (fuel-get-uses) ( lines -- ) [ parse-fresh drop ] curry with-compilation-unit ; inline diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 2e94258c28..7b90093c21 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -23,12 +23,6 @@ ;;; Customization: -(fuel-font-lock--defface fuel-font-lock-debug-missing-vocab - 'font-lock-warning-face fuel-debug "missing vocabulary names") - -(fuel-font-lock--defface fuel-font-lock-debug-unneeded-vocab - 'font-lock-warning-face fuel-debug "unneeded vocabulary names") - (fuel-font-lock--defface fuel-font-lock-debug-uses-header 'bold fuel-debug "headers in Uses buffers") @@ -53,26 +47,6 @@ (forward-line)) (reverse lines)))))) -(defun fuel-debug--highlight-names (names ref face) - (dolist (n names) - (when (not (member n ref)) - (put-text-property 0 (length n) 'font-lock-face face n)))) - -(defun fuel-debug--uses-new-uses (file uses) - (pop-to-buffer (find-file-noselect file)) - (goto-char (point-min)) - (if (re-search-forward "^USING: " nil t) - (let ((begin (point)) - (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point)))) - (kill-region begin end)) - (re-search-forward "^IN: " nil t) - (beginning-of-line) - (open-line 2) - (insert "USING: ")) - (let ((start (point))) - (insert (mapconcat 'substring-no-properties uses " ") " ;") - (fill-region start (point) nil))) - (defun fuel-debug--uses-filter (restarts) (let ((result) (i 1) (rn 0)) (dolist (r restarts (reverse result)) @@ -87,9 +61,6 @@ (fuel-popup--define fuel-debug--uses-buffer "*fuel uses*" 'fuel-debug-uses-mode) -(make-variable-buffer-local - (defvar fuel-debug--uses nil)) - (make-variable-buffer-local (defvar fuel-debug--uses-file nil)) @@ -122,22 +93,11 @@ (fuel-popup--display (fuel-debug--uses-buffer)))) (defun fuel-debug--uses-cont (retort) - (let ((uses (fuel-eval--retort-result retort)) + (let ((uses (fuel-debug--uses retort)) (err (fuel-eval--retort-error retort))) (if uses (fuel-debug--uses-display uses) (fuel-debug--uses-display-err retort)))) -(defun fuel-debug--insert-vlist (title vlist) - (goto-char (point-max)) - (insert title "\n\n ") - (let ((i 0) (step 5)) - (dolist (v vlist) - (setq i (1+ i)) - (insert v) - (insert (if (zerop (mod i step)) "\n " " "))) - (unless (zerop (mod i step)) (newline)) - (newline))) - (defun fuel-debug--uses-display (uses) (let* ((inhibit-read-only t) (old (with-current-buffer (find-file-noselect fuel-debug--uses-file) @@ -176,14 +136,15 @@ (defun fuel-debug--uses-update-usings () (interactive) - (let ((inhibit-read-only t)) - (when (and fuel-debug--uses-file fuel-debug--uses) - (fuel-debug--uses-new-uses fuel-debug--uses-file fuel-debug--uses) - (message "USING: updated!") - (with-current-buffer (fuel-debug--uses-buffer) - (insert "\nDone!") - (fuel-debug--uses-clean) - (kill-buffer (current-buffer)))))) + (let ((inhibit-read-only t) + (file fuel-debug--uses-file) + (uses fuel-debug--uses)) + (when (and uses file) + (insert "\nDone!") + (fuel-debug--uses-clean) + (fuel-popup--quit) + (fuel-debug--replace-usings file uses) + (message "USING: updated!")))) (defun fuel-debug--uses-restart (n) (when (and (> n 0) (<= n (length fuel-debug--uses-restarts))) @@ -209,11 +170,11 @@ (defconst fuel-debug--uses-header-regex (format "^%s.*$" (regexp-opt '("Infering USING: stanza for " - "Current USING: is already fine!" - "Current vocabulary list:" - "Correct vocabulary list:" - "Sorry, couldn't infer the vocabulary list." - "Done!")))) + "Current USING: is already fine!" + "Current vocabulary list:" + "Correct vocabulary list:" + "Sorry, couldn't infer the vocabulary list." + "Done!")))) (defconst fuel-debug--uses-prompt-regex (format "^%s" (regexp-opt '("Asking Factor. Please, wait ..." diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index 7643d57144..4d84ad5141 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -49,7 +49,9 @@ the debugger." (column variable-name "column numbers in errors/warnings") (info comment "information headers") (restart-number warning "restart numbers") - (restart-name function-name "restart names"))) + (restart-name function-name "restart names") + (missing-vocab warning"missing vocabulary names") + (unneeded-vocab warning "unneeded vocabulary names"))) ;;; Font lock and other pattern matching: @@ -98,6 +100,9 @@ the debugger." (make-variable-buffer-local (defvar fuel-debug--file nil)) +(make-variable-buffer-local + (defvar fuel-debug--uses nil)) + (defun fuel-debug--prepare-compilation (file msg) (let ((inhibit-read-only t)) (with-current-buffer (fuel-debug--buffer) @@ -120,6 +125,7 @@ the debugger." (fuel-debug--display-restarts err) (delete-blank-lines) (newline)) + (fuel-debug--display-uses ret) (let ((hstr (fuel-debug--help-string err fuel-debug--file))) (if fuel-debug-show-short-help (insert "-----------\n" hstr "\n") @@ -130,6 +136,46 @@ the debugger." (when (and err (not no-pop)) (fuel-popup--display)) (not err)))) +(defun fuel-debug--uses (ret) + (let ((uses (fuel-eval--retort-result ret))) + (and (eq :uses (car uses)) + (cdr uses)))) + +(defun fuel-debug--insert-vlist (title vlist) + (goto-char (point-max)) + (insert title "\n\n ") + (let ((i 0) (step 5)) + (dolist (v vlist) + (setq i (1+ i)) + (insert v) + (insert (if (zerop (mod i step)) "\n " " "))) + (unless (zerop (mod i step)) (newline)) + (newline))) + +(defun fuel-debug--highlight-names (names ref face) + (dolist (n names) + (when (not (member n ref)) + (put-text-property 0 (length n) 'font-lock-face face n)))) + +(defun fuel-debug--insert-uses (uses) + (let* ((file (or file fuel-debug--file)) + (old (with-current-buffer (find-file-noselect file) + (sort (fuel-syntax--find-usings t) 'string<))) + (new (sort uses 'string<))) + (when (not (equalp old new)) + (fuel-debug--highlight-names old new 'fuel-font-lock-debug-unneeded-vocab) + (newline) + (fuel-debug--insert-vlist "Correct vocabulary list:" new) + new))) + +(defun fuel-debug--display-uses (ret) + (when (setq fuel-debug--uses (fuel-debug--uses ret)) + (newline) + (fuel-debug--highlight-names fuel-debug--uses + nil 'fuel-font-lock-debug-missing-vocab) + (fuel-debug--insert-vlist "Missing vocabularies:" fuel-debug--uses) + (newline))) + (defun fuel-debug--display-output (ret) (let* ((last (fuel-eval--retort-output fuel-debug--last-ret)) (current (fuel-eval--retort-output ret)) @@ -155,7 +201,7 @@ the debugger." (newline)))) (defun fuel-debug--help-string (err &optional file) - (format "Press %s%s%sq bury buffer" + (format "Press %s%s%s%sq bury buffer" (if (or file (fuel-eval--error-file err)) "g go to file, " "") (let ((rsn (length (fuel-eval--error-restarts err)))) (cond ((zerop rsn) "") @@ -166,7 +212,8 @@ the debugger." (save-excursion (goto-char (point-min)) (when (search-forward (car ci) nil t) - (setq str (format "%c %s, %s" (cdr ci) (car ci) str)))))))) + (setq str (format "%c %s, %s" (cdr ci) (car ci) str)))))) + (if (and (not err) fuel-debug--uses) "u to update USING:, " ""))) (defun fuel-debug--buffer-file () (with-current-buffer (fuel-debug--buffer) @@ -235,6 +282,31 @@ the debugger." (fuel-eval--send/wait `(:fuel ((:factor ,info)))) "") (error "Sorry, no %s info available" info)))) +(defun fuel-debug--replace-usings (file uses) + (pop-to-buffer (find-file-noselect file)) + (goto-char (point-min)) + (if (re-search-forward "^USING: " nil t) + (let ((begin (point)) + (end (or (and (re-search-forward "\\_<;\\_>") (point)) (point)))) + (kill-region begin end)) + (re-search-forward "^IN: " nil t) + (beginning-of-line) + (open-line 2) + (insert "USING: ")) + (let ((start (point))) + (insert (mapconcat 'substring-no-properties uses " ") " ;") + (fill-region start (point) nil))) + +(defun fuel-debug-update-usings () + (interactive) + (when (and fuel-debug--file fuel-debug--uses) + (let* ((file fuel-debug--file) + (old (with-current-buffer (find-file-noselect file) + (fuel-syntax--find-usings t))) + (uses (sort (append fuel-debug--uses old) 'string<))) + (fuel-popup--quit) + (fuel-debug--replace-usings file uses)))) + ;;; Fuel Debug mode: @@ -245,6 +317,7 @@ the debugger." (define-key map "\C-c\C-c" 'fuel-debug-goto-error) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) + (define-key map "u" 'fuel-debug-update-usings) (dotimes (n 9) (define-key map (vector (+ ?1 n)) `(lambda () (interactive) From 796a7e9d3701dfc3343b687d54e6f5b1bb52adef Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 3 Jan 2009 16:37:28 +0100 Subject: [PATCH 17/53] FUEL: Help system overhaul. --- extra/fuel/fuel.factor | 84 +++++++- misc/fuel/README | 6 +- misc/fuel/fuel-autodoc.el | 21 +- misc/fuel/fuel-font-lock.el | 21 +- misc/fuel/fuel-help.el | 158 ++++++-------- misc/fuel/fuel-markup.el | 417 ++++++++++++++++++++++++++++++++++++ misc/fuel/fuel-xref.el | 3 +- 7 files changed, 584 insertions(+), 126 deletions(-) create mode 100644 misc/fuel/fuel-markup.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index c1d90ebbcc..a3cb6a9a22 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2008 Jose Antonio Ortega Ruiz. +! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes.tuple combinators -compiler.units continuations debugger definitions io io.pathnames -io.streams.string kernel lexer math math.order memoize namespaces -parser prettyprint sequences sets sorting source-files strings summary -tools.vocabs vectors vocabs vocabs.parser words ; +compiler.units continuations debugger definitions help help.crossref +help.markup help.topics io io.pathnames io.streams.string kernel lexer +make math math.order memoize namespaces parser prettyprint sequences +sets sorting source-files strings summary tools.vocabs vectors vocabs +vocabs.parser words ; IN: fuel @@ -56,6 +57,12 @@ GENERIC: fuel-pprint ( obj -- ) M: object fuel-pprint pprint ; inline +: fuel-maybe-scape ( ch -- seq ) + dup "?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ; + +M: word fuel-pprint + name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ; + M: f fuel-pprint drop "nil" write ; inline M: integer fuel-pprint pprint ; inline @@ -144,8 +151,8 @@ SYMBOL: :uses : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline -: fuel-with-autouse ( quot -- ) - [ auto-use? on fuel-set-use-hook call ] curry with-scope ; +: fuel-with-autouse ( quot -- ) + [ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline : (fuel-get-uses) ( lines -- ) [ parse-fresh drop ] curry with-compilation-unit ; inline @@ -218,6 +225,69 @@ MEMO: (fuel-vocab-words) ( name -- seq ) : fuel-get-words ( prefix names -- ) (fuel-get-words) fuel-eval-set-result ; inline +! Help support + +MEMO: fuel-articles-seq ( -- seq ) + articles get values ; + +: fuel-find-articles ( title -- seq ) + [ [ article-title ] dip = ] curry fuel-articles-seq swap filter ; + +MEMO: fuel-find-article ( title -- article/f ) + fuel-find-articles dup empty? [ drop f ] [ first ] if ; + +MEMO: fuel-article-title ( name -- title/f ) + articles get at [ article-title ] [ f ] if* ; + +: fuel-get-article ( name -- ) + article fuel-eval-set-result ; + +: fuel-value-str ( word -- str ) + [ pprint-short ] with-string-writer ; inline + +: fuel-definition-str ( word -- str ) + [ see ] with-string-writer ; inline + +: fuel-methods-str ( word -- str ) + methods dup empty? not [ + [ [ see nl ] each ] with-string-writer + ] [ drop f ] if ; inline + +: fuel-related-words ( word -- seq ) + dup "related" word-prop remove ; inline + +: fuel-parent-topics ( word -- seq ) + help-path [ dup article-title swap 2array ] map ; inline + +: (fuel-word-help) ( word -- element ) + dup \ article swap article-title rot + [ + { + [ fuel-parent-topics [ \ $doc-path prefix , ] unless-empty ] + [ \ $vocabulary swap vocabulary>> 2array , ] + [ word-help % ] + [ fuel-related-words [ \ $related swap 2array , ] unless-empty ] + [ get-global [ \ $value swap fuel-value-str 2array , ] when* ] + [ \ $definition swap fuel-definition-str 2array , ] + [ fuel-methods-str [ \ $methods swap 2array , ] when* ] + } cleave + ] { } make 3array ; + +MEMO: fuel-find-word ( name -- word/f ) + [ [ name>> ] dip = ] curry all-words swap filter + dup empty? not [ first ] [ drop f ] if ; + +: fuel-word-help ( name -- ) + fuel-find-word [ [ auto-use? on (fuel-word-help) ] with-scope ] [ f ] if* + fuel-eval-set-result ; inline + +: (fuel-word-see) ( word -- elem ) + [ name>> \ article swap ] + [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline + +: fuel-word-see ( name -- ) + fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if* + fuel-eval-set-result ; inline ! -run=fuel support diff --git a/misc/fuel/README b/misc/fuel/README index b670eef84d..36415bc225 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -94,10 +94,12 @@ C-cC-eC-r is the same as C-cC-er)). * In the Help browser: - - RET : help for word at point + - h : help for word at point - f/b : next/previous page - SPC/S-SPC : scroll up/down - - TAB/S-TAB : next/previous headline + - TAB/S-TAB : next/previous link + - c : clean browsing history + - M-. : edit word at point in Emacs - C-cz : switch to listener - q : bury buffer diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 151631eea1..53b5228965 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -1,6 +1,6 @@ ;;; fuel-autodoc.el -- doc snippets in the echo area -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -32,23 +32,6 @@ :type 'boolean) - -;;; Highlighting for autodoc messages: - -(defvar fuel-autodoc--font-lock-buffer - (let ((buffer (get-buffer-create " *fuel help minibuffer messages*"))) - (set-buffer buffer) - (set-syntax-table fuel-syntax--syntax-table) - (fuel-font-lock--font-lock-setup) - buffer)) - -(defun fuel-autodoc--font-lock-str (str) - (set-buffer fuel-autodoc--font-lock-buffer) - (erase-buffer) - (insert str) - (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) - (buffer-string)) - ;;; Eldoc function: @@ -65,7 +48,7 @@ (res (fuel-eval--retort-result ret))) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) (if fuel-autodoc-minibuffer-font-lock - (fuel-autodoc--font-lock-str res) + (fuel-font-lock--factor-str res) res)))))) (make-variable-buffer-local diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index 1c37de7b18..d4ce88cf20 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -1,6 +1,6 @@ ;;; fuel-font-lock.el -- font lock for factor code -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -99,5 +99,24 @@ fuel-syntax--syntactic-keywords)))))) + +;;; Fontify strings as Factor code: + +(defvar fuel-font-lock--font-lock-buffer + (let ((buffer (get-buffer-create " *fuel font lock*"))) + (set-buffer buffer) + (set-syntax-table fuel-syntax--syntax-table) + (fuel-font-lock--font-lock-setup) + buffer)) + +(defun fuel-font-lock--factor-str (str) + (save-current-buffer + (set-buffer fuel-font-lock--font-lock-buffer) + (erase-buffer) + (insert str) + (let ((font-lock-verbose nil)) (font-lock-fontify-buffer)) + (buffer-string))) + + (provide 'fuel-font-lock) ;;; fuel-font-lock.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 325e2971be..dc40463362 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -1,6 +1,6 @@ ;;; fuel-help.el -- accessing Factor's help system -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -15,12 +15,15 @@ ;;; Code: (require 'fuel-eval) +(require 'fuel-markup) (require 'fuel-autodoc) (require 'fuel-completion) (require 'fuel-font-lock) (require 'fuel-popup) (require 'fuel-base) +(require 'button) + ;;; Customization: @@ -33,32 +36,21 @@ :type 'boolean :group 'fuel-help) -(defcustom fuel-help-use-minibuffer t - "When enabled, use the minibuffer for short help messages." - :type 'boolean - :group 'fuel-help) - -(defcustom fuel-help-mode-hook nil - "Hook run by `factor-help-mode'." - :type 'hook - :group 'fuel-help) - (defcustom fuel-help-history-cache-size 50 "Maximum number of pages to keep in the help browser cache." :type 'integer :group 'fuel-help) -(fuel-font-lock--defface fuel-font-lock-help-headlines - 'bold fuel-hep "headlines in help buffers") - ;;; Help browser history: -(defvar fuel-help--history +(defun fuel-help--make-history () (list nil ; current (make-ring fuel-help-history-cache-size) ; previous (make-ring fuel-help-history-cache-size))) ; next +(defvar fuel-help--history (fuel-help--make-history)) + (defun fuel-help--history-push (term) (when (and (car fuel-help--history) (not (string= (caar fuel-help--history) (car term)))) @@ -86,94 +78,75 @@ (defvar fuel-help--prompt-history nil) -(defun fuel-help--show-help (&optional see word) - (let* ((def (or word (fuel-syntax-symbol-at-point))) +(defun fuel-help--read-word (see) + (let* ((def (fuel-syntax-symbol-at-point)) (prompt (format "See%s help on%s: " (if see " short" "") (if def (format " (%s)" def) ""))) (ask (or (not (memq major-mode '(factor-mode fuel-help-mode))) (not def) - fuel-help-always-ask)) - (def (if ask (fuel-completion--read-word prompt - def - 'fuel-help--prompt-history - t) - def)) - (cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t))) - (message "Looking up '%s' ..." def) - (fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r))))) + fuel-help-always-ask))) + (if ask (fuel-completion--read-word prompt + def + 'fuel-help--prompt-history + t) + def))) -(defun fuel-help--show-help-cont (def ret) - (let ((out (fuel-eval--retort-output ret))) - (if (or (fuel-eval--retort-error ret) (empty-string-p out)) - (message "No help for '%s'" def) - (fuel-help--insert-contents def out)))) +(defun fuel-help--word-help (&optional see word) + (let ((def (or word (fuel-help--read-word see)))) + (when def + (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) + "fuel" t))) + (message "Looking up '%s' ..." def) + (let* ((ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help for '%s'" def) + (fuel-help--insert-contents def res))))))) -(defun fuel-help--insert-contents (def str &optional nopush) +(defun fuel-help--get-article (name label) + (message "Retriving article ...") + (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (fuel-help--insert-contents label res) + (message ""))) + +(defun fuel-help--follow-link (label link type) + (let ((fuel-help-always-ask nil)) + (cond ((eq type 'word) (fuel-help--word-help nil link)) + ((eq type 'article) (fuel-help--get-article link label)) + (t (message (format "Links of type %s not yet implemented" type)))))) + +(defun fuel-help--insert-contents (def art &optional nopush) (let ((hb (fuel-help--buffer)) (inhibit-read-only t) (font-lock-verbose nil)) (set-buffer hb) (erase-buffer) - (insert str) + (if (stringp art) + (insert art) + (fuel-markup--print art) + (fuel-markup--insert-newline)) (unless nopush - (goto-char (point-min)) - (when (re-search-forward (format "^%s" def) nil t) - (beginning-of-line) - (kill-region (point-min) (point)) - (fuel-help--history-push (cons def (buffer-string))))) + (fuel-help--history-push (cons def (buffer-string)))) (set-buffer-modified-p nil) (fuel-popup--display) (goto-char (point-min)) - (message "%s" def))) - - -;;; Help mode font lock: - -(defconst fuel-help--headlines - (regexp-opt '("Class description" - "Definition" - "Errors" - "Examples" - "Generic word contract" - "Inputs and outputs" - "Methods" - "Notes" - "Parent topics:" - "See also" - "Side effects" - "Syntax" - "Variable description" - "Variable value" - "Vocabulary" - "Warning" - "Word description") - t)) - -(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines)) - -(defconst fuel-help--font-lock-keywords - `(,@fuel-font-lock--font-lock-keywords - (,fuel-help--headlines-regexp . 'fuel-font-lock-help-headlines))) - + (message ""))) ;;; Interactive help commands: -(defun fuel-help-short (&optional arg) - "See a help summary of symbol at point. -By default, the information is shown in the minibuffer. When -called with a prefix argument, the information is displayed in a -separate help buffer." - (interactive "P") - (if (if fuel-help-use-minibuffer (not arg) arg) - (fuel-help--word-synopsis) - (fuel-help--show-help t))) +(defun fuel-help-short () + "See help summary of symbol at point." + (interactive) + (fuel-help--word-help t)) (defun fuel-help () "Show extended help about the symbol at point, using a help buffer." (interactive) - (fuel-help--show-help)) + (fuel-help--word-help)) (defun fuel-help-next () "Go to next page in help browser." @@ -193,15 +166,12 @@ buffer." (error "No previous page")) (fuel-help--insert-contents (car item) (cdr item) t))) -(defun fuel-help-next-headline (&optional count) - (interactive "P") - (end-of-line) - (when (re-search-forward fuel-help--headlines-regexp nil t (or count 1)) - (beginning-of-line))) - -(defun fuel-help-previous-headline (&optional count) - (interactive "P") - (re-search-backward fuel-help--headlines-regexp nil t count)) +(defun fuel-help-clean-history () + "Clean up the help browser cache of visited pages." + (interactive) + (when (y-or-n-p "Clean browsing history? ") + (setq fuel-help--history (fuel-help--make-history))) + (message "")) ;;;; Help mode map: @@ -209,15 +179,14 @@ buffer." (defvar fuel-help-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) - (define-key map "\C-m" 'fuel-help) + (set-keymap-parent map button-buffer-map) (define-key map "b" 'fuel-help-previous) + (define-key map "c" 'fuel-help-clean-history) (define-key map "f" 'fuel-help-next) + (define-key map "h" 'fuel-help) (define-key map "l" 'fuel-help-previous) (define-key map "p" 'fuel-help-previous) (define-key map "n" 'fuel-help-next) - (define-key map (kbd "TAB") 'fuel-help-next-headline) - (define-key map (kbd "S-TAB") 'fuel-help-previous-headline) - (define-key map [(backtab)] 'fuel-help-previous-headline) (define-key map (kbd "SPC") 'scroll-up) (define-key map (kbd "S-SPC") 'scroll-down) (define-key map "\M-." 'fuel-edit-word-at-point) @@ -235,16 +204,15 @@ buffer." (kill-all-local-variables) (buffer-disable-undo) (use-local-map fuel-help-mode-map) + (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Help") (setq major-mode 'fuel-help-mode) - (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t) + (setq fuel-markup--follow-link-function 'fuel-help--follow-link) (setq fuel-autodoc-mode-string "") (fuel-autodoc-mode) - (run-mode-hooks 'fuel-help-mode-hook) - (setq buffer-read-only t)) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el new file mode 100644 index 0000000000..0c83c74040 --- /dev/null +++ b/misc/fuel/fuel-markup.el @@ -0,0 +1,417 @@ +;;; fuel-markup.el -- printing factor help markup + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Thu Jan 01, 2009 21:43 + +;;; Comentary: + +;; Utilities for printing Factor's help markup. + +;;; Code: + +(require 'fuel-eval) +(require 'fuel-font-lock) +(require 'fuel-base) + +(require 'button) +(require 'table) + + +;;; Customization: + +(fuel-font-lock--defface fuel-font-lock-markup-title + 'bold fuel-help "article titles in help buffers") + +(fuel-font-lock--defface fuel-font-lock-markup-heading + 'bold fuel-help "headlines in help buffers") + +(fuel-font-lock--defface fuel-font-lock-markup-link + 'link fuel-help "links to topics in help buffers") + +(fuel-font-lock--defface fuel-font-lock-markup-emphasis + 'italic fuel-help "emphasized words in help buffers") + +(fuel-font-lock--defface fuel-font-lock-markup-strong + 'link fuel-help "bold words in help buffers") + + +;;; Links: + +(make-variable-buffer-local + (defvar fuel-markup--follow-link-function 'fuel-markup--echo-link)) + +(define-button-type 'fuel-markup--button + 'action 'fuel-markup--follow-link + 'face 'fuel-font-lock-markup-link + 'follow-link t) + +(defun fuel-markup--follow-link (button) + (when fuel-markup--follow-link-function + (funcall fuel-markup--follow-link-function + (button-label button) + (button-get button 'markup-link) + (button-get button 'markup-link-type)))) + +(defun fuel-markup--echo-link (label link type) + (message "Link %s pointing to %s named %s" label type link)) + +(defun fuel-markup--insert-button (label link type) + (insert-text-button (format "%s" label) + :type 'fuel-markup--button + 'markup-link (format "%s" link) + 'markup-link-type type)) + +(defun fuel-markup--article-title (name) + (fuel-eval--retort-result + (fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel")))) + + +;;; Markup printers: + +(defconst fuel-markup--printers + '(($class-description . fuel-markup--class-description) + ($code . fuel-markup--code) + ($contract . fuel-markup--contract) + ($curious . fuel-markup--curious) + ($definition . fuel-markup--definition) + ($description . fuel-markup--description) + ($doc-path . fuel-markup--doc-path) + ($emphasis . fuel-markup--emphasis) + ($error-description . fuel-markup--error-description) + ($errors . fuel-markup--errors) + ($example . fuel-markup--example) + ($examples . fuel-markup--examples) + ($heading . fuel-markup--heading) + ($instance . fuel-markup--instance) + ($io-error . fuel-markup--io-error) + ($link . fuel-markup--link) + ($links . fuel-markup--links) + ($list . fuel-markup--list) + ($low-level-note . fuel-markup--low-level-note) + ($markup-example . fuel-markup--markup-example) + ($maybe . fuel-markup--maybe) + ($methods . fuel-markup--methods) + ($nl . fuel-markup--newline) + ($notes . fuel-markup--notes) + ($parsing-note . fuel-markup--parsing-note) + ($prettyprinting-note . fuel-markup--prettyprinting-note) + ($quotation . fuel-markup--quotation) + ($references . fuel-markup--references) + ($related . fuel-markup--related) + ($see . fuel-markup--see) + ($see-also . fuel-markup--see-also) + ($shuffle . fuel-markup--shuffle) + ($side-effects . fuel-markup--side-effects) + ($slot . fuel-markup--snippet) + ($snippet . fuel-markup--snippet) + ($strong . fuel-markup--strong) + ($subheading . fuel-markup--subheading) + ($subsection . fuel-markup--subsection) + ($synopsis . fuel-markup--synopsis) + ($syntax . fuel-markup--syntax) + ($table . fuel-markup--table) + ($unchecked-example . fuel-markup--example) + ($value . fuel-markup--value) + ($values . fuel-markup--values) + ($values-x/y . fuel-markup--values-x/y) + ($var-description . fuel-markup--var-description) + ($vocab-link . fuel-markup--vocab-link) + ($vocab-links . fuel-markup--vocab-links) + ($vocab-subsection . fuel-markup--vocab-subsection) + ($vocabulary . fuel-markup--vocabulary) + ($warning . fuel-markup--warning) + (article . fuel-markup--article))) + +(make-variable-buffer-local + (defvar fuel-markup--maybe-nl nil)) + +(defun fuel-markup--print (e) + (cond ((null e)) + ((stringp e) (fuel-markup--insert-string e)) + ((and (listp e) (symbolp (car e)) + (assoc (car e) fuel-markup--printers)) + (funcall (cdr (assoc (car e) fuel-markup--printers)) e)) + ((and (symbolp e) + (assoc e fuel-markup--printers)) + (funcall (cdr (assoc e fuel-markup--printers)) e)) + ((listp e) (mapc 'fuel-markup--print e)) + ((symbolp e) (fuel-markup--print (list '$link e))) + (t (insert (format "\n%S\n" e))))) + +(defun fuel-markup--maybe-nl () + (setq fuel-markup--maybe-nl (point))) + +(defun fuel-markup--insert-newline (&optional justification) + (fill-region (save-excursion (beginning-of-line) (point)) + (point) + (or justification 'left)) + (newline)) + +(defsubst fuel-markup--insert-nl-if-nb (&optional no-fill) + (unless (eq (save-excursion (beginning-of-line) (point)) (point)) + (if no-fill (newline) (fuel-markup--insert-newline)))) + +(defsubst fuel-markup--put-face (txt face) + (put-text-property 0 (length txt) 'font-lock-face face txt) + txt) + +(defun fuel-markup--insert-heading (txt &optional no-nl) + (fuel-markup--insert-nl-if-nb) + (unless (bobp) (newline)) + (fuel-markup--put-face txt 'fuel-font-lock-markup-heading) + (fuel-markup--insert-string txt) + (unless no-nl (newline))) + +(defun fuel-markup--insert-string (str) + (when fuel-markup--maybe-nl + (newline 2) + (setq fuel-markup--maybe-nl nil)) + (insert str)) + +(defun fuel-markup--article (e) + (setq fuel-markup--maybe-nl nil) + (insert (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-title)) + (newline 2) + (fuel-markup--print (car (cddr e)))) + +(defun fuel-markup--heading (e) + (fuel-markup--insert-heading (cadr e))) + +(defun fuel-markup--subheading (e) + (fuel-markup--insert-heading (cadr e))) + +(defun fuel-markup--subsection (e) + (fuel-markup--insert-nl-if-nb) + (insert " - ") + (fuel-markup--link (cons '$link (cdr e))) + (fuel-markup--maybe-nl)) + +(defun fuel-markup--newline (e) + (fuel-markup--insert-newline) + (newline)) + +(defun fuel-markup--doc-path (e) + (fuel-markup--insert-heading "Related topics") + (insert " ") + (dolist (art (cdr e)) + (fuel-markup--insert-button (car art) (cadr art) 'article) + (insert ", ")) + (delete-backward-char 2) + (fuel-markup--insert-newline 'left)) + +(defun fuel-markup--emphasis (e) + (when (stringp (cadr e)) + (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-emphasis) + (insert (cadr e)))) + +(defun fuel-markup--strong (e) + (when (stringp (cadr e)) + (fuel-markup--put-face (cadr e) 'fuel-font-lock-markup-strong) + (insert (cadr e)))) + +(defun fuel-markup--snippet (e) + (let ((snip (cadr e))) + (if (stringp snip) + (insert (fuel-font-lock--factor-str snip)) + (fuel-markup--print snip)))) + +(defun fuel-markup--code (e) + (fuel-markup--insert-nl-if-nb) + (newline) + (dolist (snip (cdr e)) + (if (stringp snip) + (insert (fuel-font-lock--factor-str snip)) + (fuel-markup--print snip)) + (newline)) + (newline)) + +(defun fuel-markup--syntax (e) + (fuel-markup--insert-heading "Syntax") + (fuel-markup--print (cons '$code (cdr e))) + (newline)) + +(defun fuel-markup--examples (e) + (fuel-markup--insert-heading "Examples") + (fuel-markup--print (cdr e))) + +(defun fuel-markup--example (e) + (fuel-markup--print (cons '$code (cdr e)))) + +(defun fuel-markup--markup-example (e) + (fuel-markup--print (cons '$code (cdr e)))) + +(defun fuel-markup--link (e) + (let* ((link (cadr e)) + (type (if (symbolp link) 'word 'article)) + (label (or (and (eq type 'article) + (fuel-markup--article-title link)) + link))) + (fuel-markup--insert-button label link type))) + +(defun fuel-markup--links (e) + (dolist (link (cdr e)) + (insert " ") + (fuel-markup--link (list '$link link)) + (insert " "))) + +(defun fuel-markup--vocab-subsection (e) + (insert (format " %S " e))) + +(defun fuel-markup--vocab-link (e) + (fuel-markup--insert-button (cadr e) (cadr e) 'vocab)) + +(defun fuel-markup--vocab-links (e) + (dolist (link (cdr e)) + (insert " ") + (fuel-markup--vocab-link (list '$vocab-link link)) + (insert " "))) + +(defun fuel-markup--vocabulary (e) + (fuel-markup--insert-heading "Vocabulary:" t) + (insert " " (cadr e)) + (newline)) + +(defun fuel-markup--list (e) + (fuel-markup--insert-nl-if-nb) + (dolist (elt (cdr e)) + (insert " - ") + (fuel-markup--print elt) + (fuel-markup--insert-newline))) + +(defun fuel-markup--table (e) + (fuel-markup--insert-newline) + (newline) + (let ((start (point)) + (col-delim "<~end-of-col~>") + (col-no (length (cadr e)))) + (dolist (row (cdr e)) + (dolist (col row) + (fuel-markup--print col) + (insert col-delim))) + (table-capture start (point) + col-delim nil nil + (/ (- (window-width) 10) col-no) col-no)) + (goto-char (point-max)) + (table-recognize -1) + (newline)) + +(defun fuel-markup--instance (e) + (insert " an instance of ") + (fuel-markup--print (cadr e))) + +(defun fuel-markup--maybe (e) + (fuel-markup--instance (cons '$instance (cdr e))) + (insert " or f ")) + +(defun fuel-markup--values (e) + (fuel-markup--insert-heading "Inputs and outputs") + (dolist (val (cdr e)) + (insert " " (car val) " - ") + (fuel-markup--print (cdr val)) + (newline))) + +(defun fuel-markup--side-effects (e) + (fuel-markup--insert-heading "Side effects") + (insert "Modifies ") + (fuel-markup--print (cdr e)) + (fuel-markup--insert-newline)) + +(defun fuel-markup--definition (e) + (fuel-markup--insert-heading "Definition") + (fuel-markup--code (cons '$code (cdr e)))) + +(defun fuel-markup--methods (e) + (fuel-markup--insert-heading "Methods") + (fuel-markup--code (cons '$code (cdr e)))) + +(defun fuel-markup--value (e) + (fuel-markup--insert-heading "Variable value") + (insert "Current value in global namespace: ") + (fuel-markup--snippet (cons '$snippet (cdr e))) + (newline)) + +(defun fuel-markup--values-x/y (e) + (fuel-markup--values '($values ("x" "number") ("y" "number")))) + +(defun fuel-markup--curious (e) + (fuel-markup--insert-heading "For the curious...") + (fuel-markup--print (cdr e))) + +(defun fuel-markup--references (e) + (fuel-markup--insert-heading "References") + (fuel-markup--links (cons '$links (cdr e)))) + +(defun fuel-markup--see-also (e) + (fuel-markup--insert-heading "See also") + (fuel-markup--links (cons '$links (cdr e)))) + +(defun fuel-markup--shuffle (e) + (insert "\nShuffle word. Re-arranges the stack " + "according to the stack effect pattern.") + (fuel-markup--insert-newline)) + +(defun fuel-markup--low-level-note (e) + (fuel-markup--print '($notes "Calling this word directly is not necessary " + "in most cases. " + "Higher-level words call it automatically."))) + +(defun fuel-markup--parsing-note (e) + (fuel-markup--insert-nl-if-nb) + (insert "This word should only be called from parsing words.") + (fuel-markup--insert-newline)) + +(defun fuel-markup--io-error (e) + (fuel-markup--errors '($errors "Throws an error if the I/O operation fails."))) + +(defun fuel-markup--prettyprinting-note (e) + (fuel-markup--print '($notes ("This word should only be called within the " + ($link with-pprint) " combinator.")))) + +(defun fuel-markup--elem-with-heading (elem heading) + (fuel-markup--insert-heading heading) + (fuel-markup--print (cdr elem)) + (fuel-markup--insert-newline)) + +(defun fuel-markup--warning (e) + (fuel-markup--elem-with-heading e "Warning")) + +(defun fuel-markup--description (e) + (fuel-markup--elem-with-heading e "Word description")) + +(defun fuel-markup--class-description (e) + (fuel-markup--elem-with-heading e "Class description")) + +(defun fuel-markup--error-description (e) + (fuel-markup--elem-with-heading e "Error description")) + +(defun fuel-markup--var-description (e) + (fuel-markup--elem-with-heading e "Variable description")) + +(defun fuel-markup--contract (e) + (fuel-markup--elem-with-heading e "Generic word contract")) + +(defun fuel-markup--related (e) + (fuel-markup--elem-with-heading e "See also")) + +(defun fuel-markup--errors (e) + (fuel-markup--elem-with-heading e "Errors")) + +(defun fuel-markup--notes (e) + (fuel-markup--elem-with-heading e "Notes")) + +(defun fuel-markup--see (e) + (insert (format " %S " e))) + +(defun fuel-markup--synopsis (e) + (insert (format " %S " e))) + +(defun fuel-markup--quotation (e) + (insert (format " %S " e))) + + +(provide 'fuel-markup) +;;; fuel-markup.el ends here diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index be976a5392..eb57c98ce2 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -1,6 +1,6 @@ ;;; fuel-xref.el -- showing cross-reference info -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -138,7 +138,6 @@ cursor at the first ocurrence of the used word." (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map button-buffer-map) - (define-key map "q" 'bury-buffer) map)) (defun fuel-xref-mode () From 1ef58cbd4385c6c52330714d478aebdffaa9130d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 3 Jan 2009 21:51:21 +0100 Subject: [PATCH 18/53] FUEL: Help index pages implemented (but no vocab-index yet). --- extra/fuel/fuel.factor | 6 +++++ misc/fuel/fuel-help.el | 2 +- misc/fuel/fuel-markup.el | 51 ++++++++++++++++++++++++++++++---------- 3 files changed, 46 insertions(+), 13 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index a3cb6a9a22..8e4249fe22 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -273,6 +273,12 @@ MEMO: fuel-article-title ( name -- title/f ) } cleave ] { } make 3array ; +: (fuel-index) ( seq -- seq ) + [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ; + +: fuel-index ( quot -- ) + call (fuel-index) fuel-eval-set-result ; inline + MEMO: fuel-find-word ( name -- word/f ) [ [ name>> ] dip = ] curry all-words swap filter dup empty? not [ first ] [ drop f ] if ; diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index dc40463362..ba77ea7ef1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -104,7 +104,7 @@ (fuel-help--insert-contents def res))))))) (defun fuel-help--get-article (name label) - (message "Retriving article ...") + (message "Retrieving article ...") (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) (ret (fuel-eval--send/wait cmd 2000)) (res (fuel-eval--retort-result ret))) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 0c83c74040..6f139b05b5 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -60,10 +60,13 @@ (message "Link %s pointing to %s named %s" label type link)) (defun fuel-markup--insert-button (label link type) - (insert-text-button (format "%s" label) - :type 'fuel-markup--button - 'markup-link (format "%s" link) - 'markup-link-type type)) + (let ((label (format "%s" label)) + (link (format "%s" link))) + (insert-text-button label + :type 'fuel-markup--button + 'markup-link link + 'markup-link-type type + 'help-echo link))) (defun fuel-markup--article-title (name) (fuel-eval--retort-result @@ -86,6 +89,7 @@ ($example . fuel-markup--example) ($examples . fuel-markup--examples) ($heading . fuel-markup--heading) + ($index . fuel-markup--index) ($instance . fuel-markup--instance) ($io-error . fuel-markup--io-error) ($link . fuel-markup--link) @@ -142,6 +146,11 @@ ((symbolp e) (fuel-markup--print (list '$link e))) (t (insert (format "\n%S\n" e))))) +(defun fuel-markup--print-str (e) + (with-temp-buffer + (fuel-markup--print e) + (buffer-string))) + (defun fuel-markup--maybe-nl () (setq fuel-markup--maybe-nl (point))) @@ -214,10 +223,8 @@ (insert (cadr e)))) (defun fuel-markup--snippet (e) - (let ((snip (cadr e))) - (if (stringp snip) - (insert (fuel-font-lock--factor-str snip)) - (fuel-markup--print snip)))) + (let ((snip (fuel-markup--print-str (cdr e)))) + (insert (fuel-font-lock--factor-str snip)))) (defun fuel-markup--code (e) (fuel-markup--insert-nl-if-nb) @@ -247,7 +254,8 @@ (defun fuel-markup--link (e) (let* ((link (cadr e)) (type (if (symbolp link) 'word 'article)) - (label (or (and (eq type 'article) + (label (or (car (cddr e)) + (and (eq type 'article) (fuel-markup--article-title link)) link))) (fuel-markup--insert-button label link type))) @@ -258,8 +266,21 @@ (fuel-markup--link (list '$link link)) (insert " "))) -(defun fuel-markup--vocab-subsection (e) - (insert (format " %S " e))) +(defun fuel-markup--index-quotation (q) + (cond ((null q) null) + ((listp q) (vconcat (mapcar 'fuel-markup--index-quotation q))) + (t q))) + +(defun fuel-markup--index (e) + (let* ((q (fuel-markup--index-quotation (cadr e))) + (cmd `(:fuel* ((,q fuel-index)) "fuel" + ("builtins" "help" "help.topics" "classes" + "classes.builtin" "classes.tuple" + "classes.singleton" "classes.union" + "classes.intersection" "classes.predicate"))) + (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200)))) + (when subs + (fuel-markup--print subs)))) (defun fuel-markup--vocab-link (e) (fuel-markup--insert-button (cadr e) (cadr e) 'vocab)) @@ -343,7 +364,10 @@ (defun fuel-markup--references (e) (fuel-markup--insert-heading "References") - (fuel-markup--links (cons '$links (cdr e)))) + (dolist (ref (cdr e)) + (if (listp ref) + (fuel-markup--print ref) + (fuel-markup--subsection (list '$subsection ref))))) (defun fuel-markup--see-also (e) (fuel-markup--insert-heading "See also") @@ -412,6 +436,9 @@ (defun fuel-markup--quotation (e) (insert (format " %S " e))) +(defun fuel-markup--vocab-subsection (e) + (insert (format " %S " e))) + (provide 'fuel-markup) ;;; fuel-markup.el ends here From 992633dd32f9131a6bdf56b2a032617e98cd098b Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 00:01:51 +0100 Subject: [PATCH 19/53] FUEL: Help system now displays vocab help. --- extra/fuel/fuel.factor | 11 +++++++++++ misc/fuel/fuel-help.el | 11 +++++++++++ misc/fuel/fuel-markup.el | 21 ++++++++++++++++----- 3 files changed, 38 insertions(+), 5 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 8e4249fe22..5306ff9d00 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -273,6 +273,17 @@ MEMO: fuel-article-title ( name -- title/f ) } cleave ] { } make 3array ; +: (fuel-vocab-help) ( name -- element ) + \ article swap dup >vocab-link + [ + [ summary [ , ] [ "No summary available" , ] if* ] + [ drop \ $nl , ] + [ vocab-help article [ content>> % ] when* ] tri + ] { } make 3array ; + +: fuel-vocab-help ( name -- ) + (fuel-vocab-help) fuel-eval-set-result ; inline + : (fuel-index) ( seq -- seq ) [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ; diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index ba77ea7ef1..8124fff19f 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -111,10 +111,21 @@ (fuel-help--insert-contents label res) (message ""))) +(defun fuel-help--get-vocab (name) + (message "Retrieving vocabulary help ...") + (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help available for vocabulary %s" name) + (fuel-help--insert-contents label res) + (message "")))) + (defun fuel-help--follow-link (label link type) (let ((fuel-help-always-ask nil)) (cond ((eq type 'word) (fuel-help--word-help nil link)) ((eq type 'article) (fuel-help--get-article link label)) + ((eq type 'vocab) (fuel-help--get-vocab link)) (t (message (format "Links of type %s not yet implemented" type)))))) (defun fuel-help--insert-contents (def art &optional nopush) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 6f139b05b5..9896c4a934 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -102,6 +102,7 @@ ($nl . fuel-markup--newline) ($notes . fuel-markup--notes) ($parsing-note . fuel-markup--parsing-note) + ($predicate . fuel-markup--predicate) ($prettyprinting-note . fuel-markup--prettyprinting-note) ($quotation . fuel-markup--quotation) ($references . fuel-markup--references) @@ -199,6 +200,12 @@ (fuel-markup--link (cons '$link (cdr e))) (fuel-markup--maybe-nl)) +(defun fuel-markup--vocab-subsection (e) + (fuel-markup--insert-nl-if-nb) + (insert " - ") + (fuel-markup--vocab-link (cons '$vocab-link (cdr e))) + (fuel-markup--maybe-nl)) + (defun fuel-markup--newline (e) (fuel-markup--insert-newline) (newline)) @@ -292,8 +299,8 @@ (insert " "))) (defun fuel-markup--vocabulary (e) - (fuel-markup--insert-heading "Vocabulary:" t) - (insert " " (cadr e)) + (fuel-markup--insert-heading "Vocabulary: " t) + (fuel-markup--vocab-link (cons '$vocab-link (cdr e))) (newline)) (defun fuel-markup--list (e) @@ -335,6 +342,13 @@ (fuel-markup--print (cdr val)) (newline))) +(defun fuel-markup--predicate (e) + (fuel-markup--values '($values ("object" object) ("?" "a boolean"))) + (let ((word (make-symbol (substring (format "%s" (cadr e)) 0 -1)))) + (fuel-markup--description + `($description "Tests if the object is an instance of the " + ($link ,word) " class.")))) + (defun fuel-markup--side-effects (e) (fuel-markup--insert-heading "Side effects") (insert "Modifies ") @@ -436,9 +450,6 @@ (defun fuel-markup--quotation (e) (insert (format " %S " e))) -(defun fuel-markup--vocab-subsection (e) - (insert (format " %S " e))) - (provide 'fuel-markup) ;;; fuel-markup.el ends here From 9832429b944f572fbfb83b5ec2780d33b91e8286 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 01:50:13 +0100 Subject: [PATCH 20/53] FUEL: Better help page caching and some fixes. --- extra/fuel/fuel.factor | 2 +- misc/fuel/fuel-help.el | 83 +++++++++++++++++++++++++++--------------- 2 files changed, 54 insertions(+), 31 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 5306ff9d00..86fdbec7c5 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -58,7 +58,7 @@ GENERIC: fuel-pprint ( obj -- ) M: object fuel-pprint pprint ; inline : fuel-maybe-scape ( ch -- seq ) - dup "?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ; + dup "\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ; M: word fuel-pprint name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ; diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 8124fff19f..36791a1b40 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -50,10 +50,20 @@ (make-ring fuel-help-history-cache-size))) ; next (defvar fuel-help--history (fuel-help--make-history)) +(defvar fuel-help--cache (make-hash-table :weakness 'key)) + +(defsubst fuel-help--cache-get (name) + (gethash name fuel-help--cache)) + +(defsubst fuel-help--cache-insert (name str) + (puthash name str fuel-help--cache)) + +(defsubst fuel-help--cache-clear () + (clrhash fuel-help--cache)) (defun fuel-help--history-push (term) (when (and (car fuel-help--history) - (not (string= (caar fuel-help--history) (car term)))) + (not (string= (car fuel-help--history) term))) (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history term)) @@ -69,6 +79,9 @@ (ring-insert (nth 2 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0)))) +(defun fuel-help--history-current-content () + (fuel-help--cache-get (car fuel-help--history))) + ;;; Fuel help buffer and internals: @@ -92,34 +105,43 @@ def))) (defun fuel-help--word-help (&optional see word) - (let ((def (or word (fuel-help--read-word see)))) - (when def - (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) - "fuel" t))) - (message "Looking up '%s' ..." def) - (let* ((ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (if (not res) - (message "No help for '%s'" def) - (fuel-help--insert-contents def res))))))) + (let* ((def (or word (fuel-help--read-word see))) + (cached (fuel-help--cache-get def))) + (if cached + (fuel-help--insert-contents def cached) + (when def + (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) + "fuel" t))) + (message "Looking up '%s' ..." def) + (let* ((ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help for '%s'" def) + (fuel-help--insert-contents def res)))))))) (defun fuel-help--get-article (name label) - (message "Retrieving article ...") - (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) - (ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (fuel-help--insert-contents label res) - (message ""))) + (let ((cached (fuel-help--cache-get name))) + (if cached + (fuel-help--insert-contents name cached) + (message "Retrieving article ...") + (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (fuel-help--insert-contents name res) + (message ""))))) (defun fuel-help--get-vocab (name) - (message "Retrieving vocabulary help ...") - (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) - (ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (if (not res) - (message "No help available for vocabulary %s" name) - (fuel-help--insert-contents label res) - (message "")))) + (let ((cached (fuel-help--cache-get name))) + (if cached + (fuel-help--insert-contents name cached) + (message "Retrieving vocabulary help ...") + (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help available for vocabulary %s" name) + (fuel-help--insert-contents name res) + (message "")))))) (defun fuel-help--follow-link (label link type) (let ((fuel-help-always-ask nil)) @@ -137,9 +159,9 @@ (if (stringp art) (insert art) (fuel-markup--print art) - (fuel-markup--insert-newline)) - (unless nopush - (fuel-help--history-push (cons def (buffer-string)))) + (fuel-markup--insert-newline) + (fuel-help--cache-insert def (buffer-string))) + (unless nopush (fuel-help--history-push def)) (set-buffer-modified-p nil) (fuel-popup--display) (goto-char (point-min)) @@ -166,7 +188,7 @@ buffer." (fuel-help-always-ask nil)) (unless item (error "No next page")) - (fuel-help--insert-contents (car item) (cdr item) t))) + (fuel-help--insert-contents item (fuel-help--cache-get item) t))) (defun fuel-help-previous () "Go to next page in help browser." @@ -175,12 +197,13 @@ buffer." (fuel-help-always-ask nil)) (unless item (error "No previous page")) - (fuel-help--insert-contents (car item) (cdr item) t))) + (fuel-help--insert-contents item (fuel-help--cache-get item) t))) (defun fuel-help-clean-history () "Clean up the help browser cache of visited pages." (interactive) (when (y-or-n-p "Clean browsing history? ") + (fuel-help--cache-clear) (setq fuel-help--history (fuel-help--make-history))) (message "")) From c13a6efe976a400f56180aaf72525d5c71b9c34a Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 02:36:58 +0100 Subject: [PATCH 21/53] FUEL: New command: fuel-apropos. --- extra/fuel/fuel.factor | 49 ++++++++++++++++++++------------------ misc/fuel/README | 3 +++ misc/fuel/fuel-help.el | 2 ++ misc/fuel/fuel-listener.el | 4 +++- misc/fuel/fuel-mode.el | 8 ++++++- misc/fuel/fuel-xref.el | 18 ++++++++------ 6 files changed, 52 insertions(+), 32 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 86fdbec7c5..9db39b1323 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -5,8 +5,8 @@ USING: accessors arrays assocs classes.tuple combinators compiler.units continuations debugger definitions help help.crossref help.markup help.topics io io.pathnames io.streams.string kernel lexer make math math.order memoize namespaces parser prettyprint sequences -sets sorting source-files strings summary tools.vocabs vectors vocabs -vocabs.parser words ; +sets sorting source-files strings summary tools.crossref tools.vocabs +vectors vocabs vocabs.parser words ; IN: fuel @@ -151,7 +151,7 @@ SYMBOL: :uses : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline -: fuel-with-autouse ( quot -- ) +: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... ) [ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline : (fuel-get-uses) ( lines -- ) @@ -184,13 +184,16 @@ SYMBOL: :uses [ [ first ] dip first <=> ] sort ; inline : fuel-format-xrefs ( seq -- seq' ) - [ word? ] filter [ fuel-word>xref ] map fuel-sort-xrefs ; + [ word? ] filter [ fuel-word>xref ] map ; inline : fuel-callers-xref ( word -- ) - usage fuel-format-xrefs fuel-eval-set-result ; inline + usage fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline : fuel-callees-xref ( word -- ) - uses fuel-format-xrefs fuel-eval-set-result ; inline + uses fuel-format-xrefs fuel-sort-xrefs fuel-eval-set-result ; inline + +: fuel-apropos-xref ( str -- ) + words-matching fuel-format-xrefs fuel-eval-set-result ; inline ! Completion support @@ -273,23 +276,6 @@ MEMO: fuel-article-title ( name -- title/f ) } cleave ] { } make 3array ; -: (fuel-vocab-help) ( name -- element ) - \ article swap dup >vocab-link - [ - [ summary [ , ] [ "No summary available" , ] if* ] - [ drop \ $nl , ] - [ vocab-help article [ content>> % ] when* ] tri - ] { } make 3array ; - -: fuel-vocab-help ( name -- ) - (fuel-vocab-help) fuel-eval-set-result ; inline - -: (fuel-index) ( seq -- seq ) - [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ; - -: fuel-index ( quot -- ) - call (fuel-index) fuel-eval-set-result ; inline - MEMO: fuel-find-word ( name -- word/f ) [ [ name>> ] dip = ] curry all-words swap filter dup empty? not [ first ] [ drop f ] if ; @@ -306,6 +292,23 @@ MEMO: fuel-find-word ( name -- word/f ) fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if* fuel-eval-set-result ; inline +: (fuel-vocab-help) ( name -- element ) + \ article swap dup >vocab-link + [ + [ summary [ , ] [ "No summary available" , ] if* ] + [ drop \ $nl , ] + [ vocab-help article [ content>> % ] when* ] tri + ] { } make 3array ; + +: fuel-vocab-help ( name -- ) + (fuel-vocab-help) fuel-eval-set-result ; inline + +: (fuel-index) ( seq -- seq ) + [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ; + +: fuel-index ( quot: ( -- seq ) -- ) + call (fuel-index) fuel-eval-set-result ; inline + ! -run=fuel support : fuel-startup ( -- ) "listener" run-file ; inline diff --git a/misc/fuel/README b/misc/fuel/README index 36415bc225..558078b9f8 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -71,6 +71,7 @@ C-cC-eC-r is the same as C-cC-er)). - C-cC-dd : help for word at point - C-cC-ds : short help word at point - C-cC-de : show stack effect of current sexp (with prefix, region) + - C-cC-dp : find words containing given substring (M-x fuel-apropos) - C-cM-<, C-cC-d< : show callers of word at point - C-cM->, C-cC-d> : show callees of word at point @@ -80,6 +81,7 @@ C-cC-eC-r is the same as C-cC-er)). - TAB : complete word at point - M-. : edit word at point in Emacs - C-ca : toggle autodoc mode + - C-cp : find words containing given substring (M-x fuel-apropos) - C-cs : toggle stack mode - C-cv : edit vocabulary - C-ch : help for word at point @@ -95,6 +97,7 @@ C-cC-eC-r is the same as C-cC-er)). * In the Help browser: - h : help for word at point + - a : find words containing given substring (M-x fuel-apropos) - f/b : next/previous page - SPC/S-SPC : scroll up/down - TAB/S-TAB : next/previous link diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 36791a1b40..1eaf0235f1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -17,6 +17,7 @@ (require 'fuel-eval) (require 'fuel-markup) (require 'fuel-autodoc) +(require 'fuel-xref) (require 'fuel-completion) (require 'fuel-font-lock) (require 'fuel-popup) @@ -214,6 +215,7 @@ buffer." (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map button-buffer-map) + (define-key map "a" 'fuel-apropos) (define-key map "b" 'fuel-help-previous) (define-key map "c" 'fuel-help-clean-history) (define-key map "f" 'fuel-help-next) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index eb159eb56e..ecb47f68a2 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -1,6 +1,6 @@ ;;; fuel-listener.el --- starting the fuel listener -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -15,6 +15,7 @@ (require 'fuel-stack) (require 'fuel-completion) +(require 'fuel-xref) (require 'fuel-eval) (require 'fuel-connection) (require 'fuel-syntax) @@ -169,6 +170,7 @@ buffer." (define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode) (define-key fuel-listener-mode-map "\C-ch" 'fuel-help) (define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode) +(define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos) (define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point) (define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary) (define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 1074f60f5f..df06584fab 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -1,6 +1,6 @@ ;;; fuel-mode.el -- Minor mode enabling FUEL niceties -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -224,6 +224,11 @@ With prefix argument, ask for word." (message "Looking up %s's callees ..." word) (fuel-xref--show-callees word)))) +(defun fuel-apropos (str) + "Show a list of words containing the given substring." + (interactive "MFind words containing: ") + (message "Looking up %s's references ..." str) + (fuel-xref--apropos str)) ;;; Minor mode definition: @@ -289,6 +294,7 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) (fuel-mode--key ?d ?a 'fuel-autodoc-mode) +(fuel-mode--key ?d ?p 'fuel-apropos) (fuel-mode--key ?d ?d 'fuel-help) (fuel-mode--key ?d ?e 'fuel-stack-effect-sexp) (fuel-mode--key ?d ?s 'fuel-help-short) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index eb57c98ce2..31f8bcb69b 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -75,11 +75,10 @@ cursor at the first ocurrence of the used word." (defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)") (defun fuel-xref--title (word cc count) - (let ((cc (if cc "using" "used by"))) - (put-text-property 0 (length word) 'font-lock-face 'bold word) - (cond ((zerop count) (format "No known words %s %s" cc word)) - ((= 1 count) (format "1 word %s %s:" cc word)) - (t (format "%s words %s %s:" count cc word))))) + (put-text-property 0 (length word) 'font-lock-face 'bold word) + (cond ((zerop count) (format "No known words %s %s" cc word)) + ((= 1 count) (format "1 word %s %s:" cc word)) + (t (format "%s words %s %s:" count cc word)))) (defun fuel-xref--insert-ref (ref) (when (and (stringp (first ref)) @@ -124,12 +123,17 @@ cursor at the first ocurrence of the used word." (defun fuel-xref--show-callers (word) (let* ((cmd `(:fuel* (((:quote ,word) fuel-callers-xref)))) (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) - (fuel-xref--fill-and-display word t res))) + (fuel-xref--fill-and-display word "using" res))) (defun fuel-xref--show-callees (word) (let* ((cmd `(:fuel* (((:quote ,word) fuel-callees-xref)))) (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) - (fuel-xref--fill-and-display word nil res))) + (fuel-xref--fill-and-display word "used by" res))) + +(defun fuel-xref--apropos (str) + (let* ((cmd `(:fuel* ((,str fuel-apropos-xref)))) + (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (fuel-xref--fill-and-display str "containing" res))) ;;; Xref mode: From 4f6426bd40c2855f512a3ebecf0d9af3085777c4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 04:04:08 +0100 Subject: [PATCH 22/53] FUEL: Help page bookmarks facility. --- misc/fuel/README | 5 +++- misc/fuel/fuel-help.el | 56 +++++++++++++++++++++++++++++++++++----- misc/fuel/fuel-markup.el | 13 +++++++--- 3 files changed, 64 insertions(+), 10 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index 558078b9f8..530047006f 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -98,7 +98,10 @@ C-cC-eC-r is the same as C-cC-er)). - h : help for word at point - a : find words containing given substring (M-x fuel-apropos) - - f/b : next/previous page + - ba : bookmark current page + - bb : display bookmarks + - bd : delete bookmark at point + - n/p : next/previous page - SPC/S-SPC : scroll up/down - TAB/S-TAB : next/previous link - c : clean browsing history diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 1eaf0235f1..da6d272d68 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -42,6 +42,10 @@ :type 'integer :group 'fuel-help) +(defcustom fuel-help-bookmarks nil + "Bookmars. Maintain this list using the help browser." + :type 'list + :group 'fuel-help) ;;; Help browser history: @@ -68,6 +72,9 @@ (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history term)) +(defsubst fuel-help--history-current () + (car fuel-help--history)) + (defun fuel-help--history-next () (when (not (ring-empty-p (nth 2 fuel-help--history))) (when (car fuel-help--history) @@ -92,6 +99,9 @@ (defvar fuel-help--prompt-history nil) +(make-local-variable + (defvar fuel-help--buffer-link nil)) + (defun fuel-help--read-word (see) (let* ((def (fuel-syntax-symbol-at-point)) (prompt (format "See%s help on%s: " (if see " short" "") @@ -118,7 +128,8 @@ (res (fuel-eval--retort-result ret))) (if (not res) (message "No help for '%s'" def) - (fuel-help--insert-contents def res)))))))) + (fuel-help--insert-contents def res)))))) + (setq fuel-help--buffer-link (list def def 'word)))) (defun fuel-help--get-article (name label) (let ((cached (fuel-help--cache-get name))) @@ -129,7 +140,8 @@ (ret (fuel-eval--send/wait cmd 2000)) (res (fuel-eval--retort-result ret))) (fuel-help--insert-contents name res) - (message ""))))) + (message ""))) + (setq fuel-help--buffer-link (list name label 'article)))) (defun fuel-help--get-vocab (name) (let ((cached (fuel-help--cache-get name))) @@ -142,7 +154,8 @@ (if (not res) (message "No help available for vocabulary %s" name) (fuel-help--insert-contents name res) - (message "")))))) + (message "")))) + (setq fuel-help--buffer-link (list name name 'vocab)))) (defun fuel-help--follow-link (label link type) (let ((fuel-help-always-ask nil)) @@ -161,7 +174,7 @@ (insert art) (fuel-markup--print art) (fuel-markup--insert-newline) - (fuel-help--cache-insert def (buffer-string))) + (when def (fuel-help--cache-insert def (buffer-string)))) (unless nopush (fuel-help--history-push def)) (set-buffer-modified-p nil) (fuel-popup--display) @@ -169,6 +182,36 @@ (message ""))) +;;; Bookmarks: + +(defun fuel-help-bookmark-page () + "Add current help page to bookmarks." + (interactive) + (let ((link fuel-help--buffer-link)) + (unless link (error "No link associated to this page")) + (add-to-list 'fuel-help-bookmarks link) + (customize-save-variable 'fuel-help-bookmarks fuel-help-bookmarks) + (message "Bookmark '%s' saved" (cadr link)))) + +(defun fuel-help-delete-bookmark () + "Delete link at point from bookmarks." + (interactive) + (let ((link (fuel-markup--link-at-point))) + (unless link (error "No link at point")) + (unless (member link fuel-help-bookmarks) + (error "'%s' is not bookmarked" (cadr link))) + (customize-save-variable 'fuel-help-bookmarks + (remove link fuel-help-bookmarks)) + (message "Bookmark '%s' delete" (cadr link)) + (fuel-help-display-bookmarks))) + +(defun fuel-help-display-bookmarks () + "Display bookmarked pages." + (interactive) + (let ((links (mapcar (lambda (l) (cons '$subsection l)) fuel-help-bookmarks))) + (unless links (error "No links to display")) + (fuel-help--insert-contents nil (list 'article "Bookmarks" links) t))) + ;;; Interactive help commands: (defun fuel-help-short () @@ -216,9 +259,10 @@ buffer." (suppress-keymap map) (set-keymap-parent map button-buffer-map) (define-key map "a" 'fuel-apropos) - (define-key map "b" 'fuel-help-previous) + (define-key map "ba" 'fuel-help-bookmark-page) + (define-key map "bb" 'fuel-help-display-bookmarks) + (define-key map "bd" 'fuel-help-delete-bookmark) (define-key map "c" 'fuel-help-clean-history) - (define-key map "f" 'fuel-help-next) (define-key map "h" 'fuel-help) (define-key map "l" 'fuel-help-previous) (define-key map "p" 'fuel-help-previous) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 9896c4a934..fa6e26b3dd 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -72,6 +72,13 @@ (fuel-eval--retort-result (fuel-eval--send/wait `(:fuel* ((,name fuel-article-title :get)) "fuel")))) +(defun fuel-markup--link-at-point () + (let ((button (condition-case nil (forward-button 0) (error nil)))) + (when button + (list (button-get button 'markup-link) + (button-label button) + (button-get button 'markup-link-type))))) + ;;; Markup printers: @@ -259,9 +266,9 @@ (fuel-markup--print (cons '$code (cdr e)))) (defun fuel-markup--link (e) - (let* ((link (cadr e)) - (type (if (symbolp link) 'word 'article)) - (label (or (car (cddr e)) + (let* ((link (nth 1 e)) + (type (or (nth 3 e) (if (symbolp link) 'word 'article))) + (label (or (nth 2 e) (and (eq type 'article) (fuel-markup--article-title link)) link))) From 77d86b8550e60ad3d5b97719e09864e745aee0b2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 15:59:54 +0100 Subject: [PATCH 23/53] FUEL: README reformatted. --- misc/fuel/README | 150 +++++++++++++++++++++++------------------------ 1 file changed, 74 insertions(+), 76 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index 530047006f..3867f284dc 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -1,116 +1,114 @@ -FUEL, Factor's Ultimate Emacs Library +FUEL, Factor's Ultimate Emacs Library -*- org -*- ------------------------------------- FUEL provides a complete environment for your Factor coding pleasure inside Emacs, including source code edition and interaction with a Factor listener instance running within Emacs. -FUEL was started by Jose A Ortega as an extension to Ed Cavazos' -original factor.el code. +FUEL was started by Jose A Ortega as an extension to Eduardo Cavazos' +original factor.el code. Eduardo is also responsible of naming the +beast. -Installation ------------- +* Installation -FUEL comes bundled with Factor's distribution. The folder misc/fuel -contains Elisp code, and there's a fuel vocabulary in extras/fuel. + FUEL comes bundled with Factor's distribution. The folder misc/fuel + contains Elisp code, and there's a fuel vocabulary in extras/fuel. -To install FUEL, either add this line to your Emacs initialisation: + To install FUEL, either add this line to your Emacs initialisation: (load-file "/misc/fuel/fu.el") -or + or (add-to-list load-path "/fuel") (require 'fuel) -If all you want is a major mode for editing Factor code with pretty -font colors and indentation, without running the factor listener -inside Emacs, you can use instead: + If all you want is a major mode for editing Factor code with pretty + font colors and indentation, without running the factor listener + inside Emacs, you can use instead: (add-to-list load-path "/fuel") (setq factor-mode-use-fuel nil) (require 'factor-mode) -Basic usage ------------ +* Basic usage -If you're using the default factor binary and images locations inside -the Factor's source tree, that should be enough to start using FUEL. -Editing any file with the extension .factor will put you in -factor-mode; try C-hm for a summary of available commands. + If you're using the default factor binary and images locations inside + the Factor's source tree, that should be enough to start using FUEL. + Editing any file with the extension .factor will put you in + factor-mode; try C-hm for a summary of available commands. -To start the listener, try M-x run-factor. + To start the listener, try M-x run-factor. -Many aspects of the environment can be customized: -M-x customize-group fuel will show you how many. + Many aspects of the environment can be customized: + M-x customize-group fuel will show you how many. -Quick key reference -------------------- +* Quick key reference -(Triple chords ending in a single letter accept also C- (e.g. -C-cC-eC-r is the same as C-cC-er)). + (Triple chords ending in a single letter accept also C- (e.g. + C-cC-eC-r is the same as C-cC-er)). -* In factor source files: +*** In factor source files: - - C-cz : switch to listener - - C-co : cycle between code, tests and docs factor files + - C-cz : switch to listener + - C-co : cycle between code, tests and docs factor files - - M-. : edit word at point in Emacs - - M-TAB : complete word at point - - C-cC-eu : update USING: line - - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary) - - C-cC-ew : edit word (M-x fuel-edit-word-at-point) - - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point) + - M-. : edit word at point in Emacs + - M-TAB : complete word at point + - C-cC-eu : update USING: line + - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary) + - C-cC-ew : edit word (M-x fuel-edit-word-at-point) + - C-cC-ed : edit word's doc (M-x fuel-edit-word-at-point) - - C-cr, C-cC-er : eval region - - C-M-r, C-cC-ee : eval region, extending it to definition boundaries - - C-M-x, C-cC-ex : eval definition around point - - C-ck, C-cC-ek : run file + - C-cr, C-cC-er : eval region + - C-M-r, C-cC-ee : eval region, extending it to definition boundaries + - C-M-x, C-cC-ex : eval definition around point + - C-ck, C-cC-ek : run file - - C-cC-da : toggle autodoc mode - - C-cC-dd : help for word at point - - C-cC-ds : short help word at point - - C-cC-de : show stack effect of current sexp (with prefix, region) - - C-cC-dp : find words containing given substring (M-x fuel-apropos) + - C-cC-da : toggle autodoc mode + - C-cC-dd : help for word at point + - C-cC-ds : short help word at point + - C-cC-de : show stack effect of current sexp (with prefix, region) + - C-cC-dp : find words containing given substring (M-x fuel-apropos) - - C-cM-<, C-cC-d< : show callers of word at point - - C-cM->, C-cC-d> : show callees of word at point + - C-cM-<, C-cC-d< : show callers of word at point + - C-cM->, C-cC-d> : show callees of word at point -* In the listener: +*** In the listener: - - TAB : complete word at point - - M-. : edit word at point in Emacs - - C-ca : toggle autodoc mode - - C-cp : find words containing given substring (M-x fuel-apropos) - - C-cs : toggle stack mode - - C-cv : edit vocabulary - - C-ch : help for word at point - - C-ck : run file + - TAB : complete word at point + - M-. : edit word at point in Emacs + - C-ca : toggle autodoc mode + - C-cp : find words containing given substring (M-x fuel-apropos) + - C-cs : toggle stack mode + - C-cv : edit vocabulary + - C-ch : help for word at point + - C-ck : run file -* In the debugger (it pops up upon eval/compilation errors): +*** In the debugger (it pops up upon eval/compilation errors): - - g : go to error - - : invoke nth restart - - w/e/l : invoke :warnings, :errors, :linkage - - q : bury buffer + - g : go to error + - : invoke nth restart + - w/e/l : invoke :warnings, :errors, :linkage + - q : bury buffer -* In the Help browser: +*** In the Help browser: - - h : help for word at point - - a : find words containing given substring (M-x fuel-apropos) - - ba : bookmark current page - - bb : display bookmarks - - bd : delete bookmark at point - - n/p : next/previous page - - SPC/S-SPC : scroll up/down - - TAB/S-TAB : next/previous link - - c : clean browsing history - - M-. : edit word at point in Emacs - - C-cz : switch to listener - - q : bury buffer + - h : help for word at point + - a : find words containing given substring (M-x fuel-apropos) + - ba : bookmark current page + - bb : display bookmarks + - bd : delete bookmark at point + - n/p : next/previous page + - SPC/S-SPC : scroll up/down + - TAB/S-TAB : next/previous link + - c : clean browsing history + - M-. : edit word at point in Emacs + - C-cz : switch to listener + - q : bury buffer -* In crossref buffers +*** In crossref buffers - - TAB/BACKTAB : navigate links - - RET/mouse click : follow link - - q : bury buffer + - TAB/BACKTAB : navigate links + - RET/mouse click : follow link + - q : bury buffer From e603602e18fd4b98f74465c056fb24a8547cf2a2 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 16:01:03 +0100 Subject: [PATCH 24/53] FUEL: Fixes in help browser navigation and new refresh command. --- extra/fuel/fuel.factor | 2 +- misc/fuel/README | 3 +- misc/fuel/fuel-help.el | 167 ++++++++++++++++++++------------------- misc/fuel/fuel-markup.el | 8 +- 4 files changed, 95 insertions(+), 85 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 9db39b1323..80d8cde654 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -58,7 +58,7 @@ GENERIC: fuel-pprint ( obj -- ) M: object fuel-pprint pprint ; inline : fuel-maybe-scape ( ch -- seq ) - dup "\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ; + dup "\\\"?#()[]'`" member? [ CHAR: \ swap 2array ] [ 1array ] if ; M: word fuel-pprint name>> V{ } clone [ fuel-maybe-scape append ] reduce >string write ; diff --git a/misc/fuel/README b/misc/fuel/README index 3867f284dc..6c03c7aa01 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -92,7 +92,7 @@ beast. - w/e/l : invoke :warnings, :errors, :linkage - q : bury buffer -*** In the Help browser: +*** In the help browser: - h : help for word at point - a : find words containing given substring (M-x fuel-apropos) @@ -102,6 +102,7 @@ beast. - n/p : next/previous page - SPC/S-SPC : scroll up/down - TAB/S-TAB : next/previous link + - r : refresh page - c : clean browsing history - M-. : edit word at point in Emacs - C-cz : switch to listener diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index da6d272d68..85746cd929 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -46,6 +46,7 @@ "Bookmars. Maintain this list using the help browser." :type 'list :group 'fuel-help) + ;;; Help browser history: @@ -54,27 +55,14 @@ (make-ring fuel-help-history-cache-size) ; previous (make-ring fuel-help-history-cache-size))) ; next -(defvar fuel-help--history (fuel-help--make-history)) -(defvar fuel-help--cache (make-hash-table :weakness 'key)) - -(defsubst fuel-help--cache-get (name) - (gethash name fuel-help--cache)) - -(defsubst fuel-help--cache-insert (name str) - (puthash name str fuel-help--cache)) - -(defsubst fuel-help--cache-clear () - (clrhash fuel-help--cache)) - -(defun fuel-help--history-push (term) - (when (and (car fuel-help--history) - (not (string= (car fuel-help--history) term))) - (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) - (setcar fuel-help--history term)) - (defsubst fuel-help--history-current () (car fuel-help--history)) +(defun fuel-help--history-push (link) + (when (and link (not (equal link (car fuel-help--history)))) + (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) + (setcar fuel-help--history link)) + (defun fuel-help--history-next () (when (not (ring-empty-p (nth 2 fuel-help--history))) (when (car fuel-help--history) @@ -87,9 +75,25 @@ (ring-insert (nth 2 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0)))) +(defvar fuel-help--history (fuel-help--make-history)) + + +;;; Page cache: + (defun fuel-help--history-current-content () (fuel-help--cache-get (car fuel-help--history))) +(defvar fuel-help--cache (make-hash-table :test 'equal)) + +(defsubst fuel-help--cache-get (name) + (gethash name fuel-help--cache)) + +(defsubst fuel-help--cache-insert (name str) + (puthash name str fuel-help--cache)) + +(defsubst fuel-help--cache-clear () + (clrhash fuel-help--cache)) + ;;; Fuel help buffer and internals: @@ -116,66 +120,62 @@ def))) (defun fuel-help--word-help (&optional see word) - (let* ((def (or word (fuel-help--read-word see))) - (cached (fuel-help--cache-get def))) - (if cached - (fuel-help--insert-contents def cached) - (when def - (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) - "fuel" t))) - (message "Looking up '%s' ..." def) - (let* ((ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (if (not res) - (message "No help for '%s'" def) - (fuel-help--insert-contents def res)))))) - (setq fuel-help--buffer-link (list def def 'word)))) + (let ((def (or word (fuel-help--read-word see)))) + (when def + (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) + "fuel" t))) + (message "Looking up '%s' ..." def) + (let* ((ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help for '%s'" def) + (fuel-help--insert-contents (list def def 'word) res))))))) (defun fuel-help--get-article (name label) - (let ((cached (fuel-help--cache-get name))) - (if cached - (fuel-help--insert-contents name cached) - (message "Retrieving article ...") - (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) - (ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (fuel-help--insert-contents name res) - (message ""))) - (setq fuel-help--buffer-link (list name label 'article)))) + (message "Retrieving article ...") + (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "Article '%s' not found" label) + (fuel-help--insert-contents (list name label 'article) res) + (message "")))) (defun fuel-help--get-vocab (name) - (let ((cached (fuel-help--cache-get name))) - (if cached - (fuel-help--insert-contents name cached) - (message "Retrieving vocabulary help ...") - (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) - (ret (fuel-eval--send/wait cmd 2000)) - (res (fuel-eval--retort-result ret))) - (if (not res) - (message "No help available for vocabulary %s" name) - (fuel-help--insert-contents name res) - (message "")))) - (setq fuel-help--buffer-link (list name name 'vocab)))) + (message "Retrieving vocabulary help ...") + (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) + (ret (fuel-eval--send/wait cmd 2000)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No help available for vocabulary '%s'" name) + (fuel-help--insert-contents (list name name 'vocab) res) + (message "")))) -(defun fuel-help--follow-link (label link type) - (let ((fuel-help-always-ask nil)) - (cond ((eq type 'word) (fuel-help--word-help nil link)) - ((eq type 'article) (fuel-help--get-article link label)) - ((eq type 'vocab) (fuel-help--get-vocab link)) - (t (message (format "Links of type %s not yet implemented" type)))))) +(defun fuel-help--follow-link (link label type &optional no-cache) + (let* ((llink (list link label type)) + (cached (and (not no-cache) (fuel-help--cache-get llink)))) + (if (not cached) + (let ((fuel-help-always-ask nil)) + (cond ((eq type 'word) (fuel-help--word-help nil link)) + ((eq type 'article) (fuel-help--get-article link label)) + ((eq type 'vocab) (fuel-help--get-vocab link)) + ((eq type 'bookmarks) (fuel-help-display-bookmarks)) + (t (error "Links of type %s not yet implemented" type)))) + (fuel-help--insert-contents llink cached)))) -(defun fuel-help--insert-contents (def art &optional nopush) +(defun fuel-help--insert-contents (key content) (let ((hb (fuel-help--buffer)) (inhibit-read-only t) (font-lock-verbose nil)) (set-buffer hb) (erase-buffer) - (if (stringp art) - (insert art) - (fuel-markup--print art) + (if (stringp content) + (insert content) + (fuel-markup--print content) (fuel-markup--insert-newline) - (when def (fuel-help--cache-insert def (buffer-string)))) - (unless nopush (fuel-help--history-push def)) + (fuel-help--cache-insert key (buffer-string))) + (fuel-help--history-push key) + (setq fuel-help--buffer-link key) (set-buffer-modified-p nil) (fuel-popup--display) (goto-char (point-min)) @@ -210,7 +210,9 @@ (interactive) (let ((links (mapcar (lambda (l) (cons '$subsection l)) fuel-help-bookmarks))) (unless links (error "No links to display")) - (fuel-help--insert-contents nil (list 'article "Bookmarks" links) t))) + (fuel-help--insert-contents '("bookmarks" "Bookmars" bookmarks) + `(article "Bookmarks" ,links)))) + ;;; Interactive help commands: @@ -228,27 +230,30 @@ buffer." (defun fuel-help-next () "Go to next page in help browser." (interactive) - (let ((item (fuel-help--history-next)) - (fuel-help-always-ask nil)) - (unless item - (error "No next page")) - (fuel-help--insert-contents item (fuel-help--cache-get item) t))) + (let ((item (fuel-help--history-next))) + (unless item (error "No next page")) + (apply 'fuel-help--follow-link item))) (defun fuel-help-previous () - "Go to next page in help browser." + "Go to previous page in help browser." (interactive) - (let ((item (fuel-help--history-previous)) - (fuel-help-always-ask nil)) - (unless item - (error "No previous page")) - (fuel-help--insert-contents item (fuel-help--cache-get item) t))) + (let ((item (fuel-help--history-previous))) + (unless item (error "No previous page")) + (apply 'fuel-help--follow-link item))) + +(defun fuel-help-refresh () + "Refresh the contents of current page." + (interactive) + (when fuel-help--buffer-link + (apply 'fuel-help--follow-link (append fuel-help--buffer-link '(t))))) (defun fuel-help-clean-history () "Clean up the help browser cache of visited pages." (interactive) (when (y-or-n-p "Clean browsing history? ") (fuel-help--cache-clear) - (setq fuel-help--history (fuel-help--make-history))) + (setq fuel-help--history (fuel-help--make-history)) + (fuel-help-refresh)) (message "")) @@ -264,9 +269,9 @@ buffer." (define-key map "bd" 'fuel-help-delete-bookmark) (define-key map "c" 'fuel-help-clean-history) (define-key map "h" 'fuel-help) - (define-key map "l" 'fuel-help-previous) - (define-key map "p" 'fuel-help-previous) (define-key map "n" 'fuel-help-next) + (define-key map "p" 'fuel-help-previous) + (define-key map "r" 'fuel-help-refresh) (define-key map (kbd "SPC") 'scroll-up) (define-key map (kbd "S-SPC") 'scroll-down) (define-key map "\M-." 'fuel-edit-word-at-point) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index fa6e26b3dd..87092755c9 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -52,11 +52,11 @@ (defun fuel-markup--follow-link (button) (when fuel-markup--follow-link-function (funcall fuel-markup--follow-link-function - (button-label button) (button-get button 'markup-link) + (button-label button) (button-get button 'markup-link-type)))) -(defun fuel-markup--echo-link (label link type) +(defun fuel-markup--echo-link (link label type) (message "Link %s pointing to %s named %s" label type link)) (defun fuel-markup--insert-button (label link type) @@ -85,6 +85,7 @@ (defconst fuel-markup--printers '(($class-description . fuel-markup--class-description) ($code . fuel-markup--code) + ($command . fuel-markup--command) ($contract . fuel-markup--contract) ($curious . fuel-markup--curious) ($definition . fuel-markup--definition) @@ -250,6 +251,9 @@ (newline)) (newline)) +(defun fuel-markup--command (e) + (fuel-markup--snippet (list '$snippet (nth 3 e)))) + (defun fuel-markup--syntax (e) (fuel-markup--insert-heading "Syntax") (fuel-markup--print (cons '$code (cdr e))) From b05a2388f0a55ab7fff7ba0de546e3394b8d5c89 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 19:17:04 +0100 Subject: [PATCH 25/53] FUEL: Avoid contiguous duplicates in help history. --- misc/fuel/fuel-help.el | 10 +++++++--- misc/fuel/fuel-markup.el | 11 ++++++----- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 85746cd929..22ee00f1a6 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -59,9 +59,13 @@ (car fuel-help--history)) (defun fuel-help--history-push (link) - (when (and link (not (equal link (car fuel-help--history)))) - (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) - (setcar fuel-help--history link)) + (unless (equal link (car fuel-help--history)) + (let ((next (fuel-help--history-next))) + (unless (equal link next) + (when next (fuel-help--history-previous)) + (ring-insert (nth 1 fuel-help--history) (car fuel-help--history)) + (setcar fuel-help--history link)))) + link) (defun fuel-help--history-next () (when (not (ring-empty-p (nth 2 fuel-help--history))) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 87092755c9..c1f9cf3a7d 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -280,9 +280,9 @@ (defun fuel-markup--links (e) (dolist (link (cdr e)) - (insert " ") (fuel-markup--link (list '$link link)) - (insert " "))) + (insert ", ")) + (delete-backward-char 2)) (defun fuel-markup--index-quotation (q) (cond ((null q) null) @@ -398,6 +398,10 @@ (fuel-markup--insert-heading "See also") (fuel-markup--links (cons '$links (cdr e)))) +(defun fuel-markup--related (e) + (fuel-markup--insert-heading "See also") + (fuel-markup--links (cons '$links (cadr e)))) + (defun fuel-markup--shuffle (e) (insert "\nShuffle word. Re-arranges the stack " "according to the stack effect pattern.") @@ -443,9 +447,6 @@ (defun fuel-markup--contract (e) (fuel-markup--elem-with-heading e "Generic word contract")) -(defun fuel-markup--related (e) - (fuel-markup--elem-with-heading e "See also")) - (defun fuel-markup--errors (e) (fuel-markup--elem-with-heading e "Errors")) From b5110ccdb69d372a3ea44f1c8738ca9b72695ec5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sun, 4 Jan 2009 19:40:22 +0100 Subject: [PATCH 26/53] FUEL: Fixes in help pages caching. --- misc/fuel/fuel-help.el | 2 +- misc/fuel/fuel-markup.el | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 22ee00f1a6..2c936f5557 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -87,7 +87,7 @@ (defun fuel-help--history-current-content () (fuel-help--cache-get (car fuel-help--history))) -(defvar fuel-help--cache (make-hash-table :test 'equal)) +(defvar fuel-help--cache (make-hash-table :weakness 'key :test 'equal)) (defsubst fuel-help--cache-get (name) (gethash name fuel-help--cache)) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index c1f9cf3a7d..2ee120c296 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -53,7 +53,7 @@ (when fuel-markup--follow-link-function (funcall fuel-markup--follow-link-function (button-get button 'markup-link) - (button-label button) + (button-get button 'markup-label) (button-get button 'markup-link-type)))) (defun fuel-markup--echo-link (link label type) @@ -65,8 +65,9 @@ (insert-text-button label :type 'fuel-markup--button 'markup-link link + 'markup-label label 'markup-link-type type - 'help-echo link))) + 'help-echo (format "%s (%s)" label type)))) (defun fuel-markup--article-title (name) (fuel-eval--retort-result @@ -76,7 +77,7 @@ (let ((button (condition-case nil (forward-button 0) (error nil)))) (when button (list (button-get button 'markup-link) - (button-label button) + (button-get button 'markup-label) (button-get button 'markup-link-type))))) From c7b589f7127a8a4128d10d9d0d37b57a7bb06606 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 04:58:19 +0100 Subject: [PATCH 27/53] FUEL: $quotation and $see markup; no autodoc by default in help buffers. --- misc/fuel/fuel-help.el | 5 ----- misc/fuel/fuel-markup.el | 27 +++++++++++++++++++-------- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 2c936f5557..12091ea399 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -296,12 +296,7 @@ buffer." (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Help") (setq major-mode 'fuel-help-mode) - (setq fuel-markup--follow-link-function 'fuel-help--follow-link) - - (setq fuel-autodoc-mode-string "") - (fuel-autodoc-mode) - (setq buffer-read-only t)) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 2ee120c296..a2c94d4f4a 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -239,7 +239,7 @@ (insert (cadr e)))) (defun fuel-markup--snippet (e) - (let ((snip (fuel-markup--print-str (cdr e)))) + (let ((snip (format "%s" (cdr e)))) (insert (fuel-font-lock--factor-str snip)))) (defun fuel-markup--code (e) @@ -262,13 +262,15 @@ (defun fuel-markup--examples (e) (fuel-markup--insert-heading "Examples") - (fuel-markup--print (cdr e))) + (dolist (ex (cdr e)) + (fuel-markup--print ex) + (newline))) (defun fuel-markup--example (e) - (fuel-markup--print (cons '$code (cdr e)))) + (fuel-markup--snippet (list '$snippet (cadr e)))) (defun fuel-markup--markup-example (e) - (fuel-markup--print (cons '$code (cdr e)))) + (fuel-markup--snippet (cons '$snippet (cadr e)))) (defun fuel-markup--link (e) (let* ((link (nth 1 e)) @@ -430,6 +432,12 @@ (fuel-markup--print (cdr elem)) (fuel-markup--insert-newline)) +(defun fuel-markup--quotation (e) + (insert "a ") + (fuel-markup--link (list '$link 'quotation 'quotation 'word)) + (insert " with stack effect ") + (fuel-markup--snippet (list '$snippet (nth 1 e)))) + (defun fuel-markup--warning (e) (fuel-markup--elem-with-heading e "Warning")) @@ -455,14 +463,17 @@ (fuel-markup--elem-with-heading e "Notes")) (defun fuel-markup--see (e) - (insert (format " %S " e))) + (let* ((word (nth 1 e)) + (cmd (and word `(:fuel* (,(format "%s" word) fuel-word-see) "fuel" t))) + (res (and cmd + (fuel-eval--retort-result (fuel-eval--send/wait cmd 100))))) + (if res + (fuel-markup--code (list '$code res)) + (fuel-markup--snippet (list '$snippet word))))) (defun fuel-markup--synopsis (e) (insert (format " %S " e))) -(defun fuel-markup--quotation (e) - (insert (format " %S " e))) - (provide 'fuel-markup) ;;; fuel-markup.el ends here From a0f3a44aa064fd3cc99f71069b8700a73397060f Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 06:22:36 +0100 Subject: [PATCH 28/53] FUEL: New command fuel-help-kill-page (bound to 'k' in help browser). --- extra/fuel/fuel.factor | 8 +++++--- misc/fuel/README | 1 + misc/fuel/fuel-connection.el | 4 ++-- misc/fuel/fuel-eval.el | 6 ++++-- misc/fuel/fuel-help.el | 34 ++++++++++++++++++++++------------ 5 files changed, 34 insertions(+), 19 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 80d8cde654..03896029f1 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -4,9 +4,9 @@ USING: accessors arrays assocs classes.tuple combinators compiler.units continuations debugger definitions help help.crossref help.markup help.topics io io.pathnames io.streams.string kernel lexer -make math math.order memoize namespaces parser prettyprint sequences -sets sorting source-files strings summary tools.crossref tools.vocabs -vectors vocabs vocabs.parser words ; +make math math.order memoize namespaces parser quotations prettyprint +sequences sets sorting source-files strings summary tools.crossref +tools.vocabs vectors vocabs vocabs.parser words ; IN: fuel @@ -74,6 +74,8 @@ M: sequence fuel-pprint M: tuple fuel-pprint tuple>array fuel-pprint ; inline +M: quotation fuel-pprint pprint ; inline + M: continuation fuel-pprint drop ":continuation" write ; inline M: restart fuel-pprint name>> fuel-pprint ; inline diff --git a/misc/fuel/README b/misc/fuel/README index 6c03c7aa01..7c746ff305 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -102,6 +102,7 @@ beast. - n/p : next/previous page - SPC/S-SPC : scroll up/down - TAB/S-TAB : next/previous link + - k : kill current page and go to previous or next - r : refresh page - c : clean browsing history - M-. : edit word at point in Emacs diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 05ddad4b1e..09d1ddfb51 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -1,6 +1,6 @@ ;;; fuel-connection.el -- asynchronous comms with the fuel listener -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -193,7 +193,7 @@ (condition-case cerr (with-current-buffer (or buffer (current-buffer)) (funcall cont (fuel-con--comint-buffer-form)) - (fuel-log--info "<%s>: processed\n\t%s" id req)) + (fuel-log--info "<%s>: processed" id)) (error (fuel-log--error "<%s>: continuation failed %S \n\t%s" id rstr cerr)))))) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 078a7005f8..149e608964 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -1,6 +1,6 @@ ;;; fuel-eval.el --- evaluating Factor expressions -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -13,9 +13,10 @@ ;;; Code: -(require 'fuel-base) (require 'fuel-syntax) (require 'fuel-connection) +(require 'fuel-log) +(require 'fuel-base) (eval-when-compile (require 'cl)) @@ -125,6 +126,7 @@ (fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil)) (defun fuel-eval--parse-retort (ret) + (fuel-log--info "RETORT: %S" ret) (if (fuel-eval--retort-p ret) ret (fuel-eval--make-parse-error-retort ret))) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 12091ea399..4b8d1e4e16 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -67,15 +67,15 @@ (setcar fuel-help--history link)))) link) -(defun fuel-help--history-next () +(defun fuel-help--history-next (&optional forget-current) (when (not (ring-empty-p (nth 2 fuel-help--history))) - (when (car fuel-help--history) + (when (and (car fuel-help--history) (not forget-current)) (ring-insert (nth 1 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history (ring-remove (nth 2 fuel-help--history) 0)))) -(defun fuel-help--history-previous () +(defun fuel-help--history-previous (&optional forget-current) (when (not (ring-empty-p (nth 1 fuel-help--history))) - (when (car fuel-help--history) + (when (and (car fuel-help--history) (not forget-current)) (ring-insert (nth 2 fuel-help--history) (car fuel-help--history))) (setcar fuel-help--history (ring-remove (nth 1 fuel-help--history) 0)))) @@ -231,20 +231,29 @@ buffer." (interactive) (fuel-help--word-help)) -(defun fuel-help-next () - "Go to next page in help browser." - (interactive) - (let ((item (fuel-help--history-next))) +(defun fuel-help-next (&optional forget-current) + "Go to next page in help browser. +With prefix, the current page is deleted from history." + (interactive "P") + (let ((item (fuel-help--history-next forget-current))) (unless item (error "No next page")) (apply 'fuel-help--follow-link item))) -(defun fuel-help-previous () - "Go to previous page in help browser." - (interactive) - (let ((item (fuel-help--history-previous))) +(defun fuel-help-previous (&optional forget-current) + "Go to previous page in help browser. +With prefix, the current page is deleted from history." + (interactive "P") + (let ((item (fuel-help--history-previous forget-current))) (unless item (error "No previous page")) (apply 'fuel-help--follow-link item))) +(defun fuel-help-kill-page () + "Kill current page if a previous or next one exists." + (interactive) + (condition-case nil + (fuel-help-previous t) + (error (fuel-help-next t)))) + (defun fuel-help-refresh () "Refresh the contents of current page." (interactive) @@ -273,6 +282,7 @@ buffer." (define-key map "bd" 'fuel-help-delete-bookmark) (define-key map "c" 'fuel-help-clean-history) (define-key map "h" 'fuel-help) + (define-key map "k" 'fuel-help-kill-page) (define-key map "n" 'fuel-help-next) (define-key map "p" 'fuel-help-previous) (define-key map "r" 'fuel-help-refresh) From fd35c362ef91b9e5f1ad840dbe34d26169863065 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 07:08:45 +0100 Subject: [PATCH 29/53] FUEL: 'h' for help on word at point in xref buffers. --- misc/fuel/README | 2 ++ misc/fuel/fuel-help.el | 21 ++++++++++++++++----- misc/fuel/fuel-xref.el | 10 +++++++++- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index 7c746ff305..700996ba4f 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -100,6 +100,7 @@ beast. - bb : display bookmarks - bd : delete bookmark at point - n/p : next/previous page + - l : previous page - SPC/S-SPC : scroll up/down - TAB/S-TAB : next/previous link - k : kill current page and go to previous or next @@ -113,4 +114,5 @@ beast. - TAB/BACKTAB : navigate links - RET/mouse click : follow link + - h : show help for word at point - q : bury buffer diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 4b8d1e4e16..7c165e5de7 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -17,8 +17,8 @@ (require 'fuel-eval) (require 'fuel-markup) (require 'fuel-autodoc) -(require 'fuel-xref) (require 'fuel-completion) +(require 'fuel-syntax) (require 'fuel-font-lock) (require 'fuel-popup) (require 'fuel-base) @@ -114,10 +114,9 @@ (let* ((def (fuel-syntax-symbol-at-point)) (prompt (format "See%s help on%s: " (if see " short" "") (if def (format " (%s)" def) ""))) - (ask (or (not (memq major-mode '(factor-mode fuel-help-mode))) - (not def) - fuel-help-always-ask))) - (if ask (fuel-completion--read-word prompt + (ask (or (not def) fuel-help-always-ask))) + (if ask + (fuel-completion--read-word prompt def 'fuel-help--prompt-history t) @@ -284,6 +283,7 @@ With prefix, the current page is deleted from history." (define-key map "h" 'fuel-help) (define-key map "k" 'fuel-help-kill-page) (define-key map "n" 'fuel-help-next) + (define-key map "l" 'fuel-help-last) (define-key map "p" 'fuel-help-previous) (define-key map "r" 'fuel-help-refresh) (define-key map (kbd "SPC") 'scroll-up) @@ -293,6 +293,16 @@ With prefix, the current page is deleted from history." (define-key map "\C-c\C-z" 'run-factor) map)) + +;;; IN: support + +(defun fuel-help--find-in () + (save-excursion + (or (fuel-syntax--find-in) + (and (goto-char (point-min)) + (re-search-forward "Vocabulary: \\(.+\\)$" nil t) + (match-string-no-properties 1))))) + ;;; Help mode definition: @@ -306,6 +316,7 @@ With prefix, the current page is deleted from history." (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Help") (setq major-mode 'fuel-help-mode) + (setq fuel-syntax--current-vocab-function 'fuel-help--find-in) (setq fuel-markup--follow-link-function 'fuel-help--follow-link) (setq buffer-read-only t)) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 31f8bcb69b..470c2a8762 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -13,6 +13,7 @@ ;;; Code: +(require 'fuel-help) (require 'fuel-eval) (require 'fuel-syntax) (require 'fuel-popup) @@ -72,7 +73,8 @@ cursor at the first ocurrence of the used word." (make-local-variable (defvar fuel-xref--word nil)) -(defvar fuel-xref--help-string "(Press RET or click to follow crossrefs)") +(defvar fuel-xref--help-string + "(Press RET or click to follow crossrefs, or h for help on word at point)") (defun fuel-xref--title (word cc count) (put-text-property 0 (length word) 'font-lock-face 'bold word) @@ -138,10 +140,16 @@ cursor at the first ocurrence of the used word." ;;; Xref mode: +(defun fuel-xref-show-help () + (interactive) + (let ((fuel-help-always-ask nil)) + (fuel-help))) + (defvar fuel-xref-mode-map (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map button-buffer-map) + (define-key map "h" 'fuel-xref-show-help) map)) (defun fuel-xref-mode () From 63b86900e78d114e4aa35bd0d606cde1ceaab0cf Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 5 Jan 2009 04:11:43 -0600 Subject: [PATCH 30/53] Add L-system (complete rewrite of lsys) --- extra/L-system/L-system.factor | 448 +++++++++++++++++++++++++++++++++ 1 file changed, 448 insertions(+) create mode 100644 extra/L-system/L-system.factor diff --git a/extra/L-system/L-system.factor b/extra/L-system/L-system.factor new file mode 100644 index 0000000000..97a971de47 --- /dev/null +++ b/extra/L-system/L-system.factor @@ -0,0 +1,448 @@ + +USING: accessors arrays assocs colors combinators.short-circuit +kernel locals math math.functions math.matrices math.order +math.parser math.trig math.vectors opengl opengl.demo-support +opengl.gl sbufs sequences strings ui.gadgets ui.gadgets.worlds +ui.gestures ui.render ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +IN: L-system + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: pos ori angle length thickness color vertices saved ; + +DEFER: default-L-parser-values + +: reset-turtle ( turtle -- turtle ) + { 0 0 0 } clone >>pos + 3 identity-matrix >>ori + V{ } clone >>vertices + V{ } clone >>saved + + default-L-parser-values ; + +: turtle ( -- turtle ) new reset-turtle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: step-turtle ( TURTLE LENGTH -- turtle ) + + TURTLE + TURTLE pos>> TURTLE ori>> { 0 0 LENGTH } m.v v+ + >>pos ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: Rx ( ANGLE -- Rx ) + + [let | ANGLE [ ANGLE deg>rad ] | + + [let | A [ ANGLE cos ] + B [ ANGLE sin neg ] + C [ ANGLE sin ] + D [ ANGLE cos ] | + + { { 1 0 0 } + { 0 A B } + { 0 C D } } + + ] ] ; + +:: Ry ( ANGLE -- Ry ) + + [let | ANGLE [ ANGLE deg>rad ] | + + [let | A [ ANGLE cos ] + B [ ANGLE sin ] + C [ ANGLE sin neg ] + D [ ANGLE cos ] | + + { { A 0 B } + { 0 1 0 } + { C 0 D } } + + ] ] ; + +:: Rz ( ANGLE -- Rz ) + + [let | ANGLE [ ANGLE deg>rad ] | + + [let | A [ ANGLE cos ] + B [ ANGLE sin neg ] + C [ ANGLE sin ] + D [ ANGLE cos ] | + + { { A B 0 } + { C D 0 } + { 0 0 1 } } + + ] ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: apply-rotation ( TURTLE ROTATION -- turtle ) + + TURTLE TURTLE ori>> ROTATION m. >>ori ; + +: rotate-x ( turtle angle -- turtle ) Rx apply-rotation ; +: rotate-y ( turtle angle -- turtle ) Ry apply-rotation ; +: rotate-z ( turtle angle -- turtle ) Rz apply-rotation ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: pitch-up ( turtle angle -- turtle ) neg rotate-x ; +: pitch-down ( turtle angle -- turtle ) rotate-x ; + +: turn-left ( turtle angle -- turtle ) rotate-y ; +: turn-right ( turtle angle -- turtle ) neg rotate-y ; + +: roll-left ( turtle angle -- turtle ) neg rotate-z ; +: roll-right ( turtle angle -- turtle ) rotate-z ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: V ( -- V ) { 0 1 0 } ; + +: X ( turtle -- 3array ) ori>> [ first ] map ; +: Y ( turtle -- 3array ) ori>> [ second ] map ; +: Z ( turtle -- 3array ) ori>> [ third ] map ; + +: set-X ( turtle seq -- turtle ) over ori>> [ set-first ] 2each ; +: set-Y ( turtle seq -- turtle ) over ori>> [ set-second ] 2each ; +: set-Z ( turtle seq -- turtle ) over ori>> [ set-third ] 2each ; + +:: roll-until-horizontal ( TURTLE -- turtle ) + + TURTLE + + V TURTLE Z cross normalize set-X + + TURTLE Z TURTLE X cross normalize set-Y ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: strafe-up ( TURTLE LENGTH -- turtle ) + TURTLE 90 pitch-up LENGTH step-turtle 90 pitch-down ; + +:: strafe-down ( TURTLE LENGTH -- turtle ) + TURTLE 90 pitch-down LENGTH step-turtle 90 pitch-up ; + +:: strafe-left ( TURTLE LENGTH -- turtle ) + TURTLE 90 turn-left LENGTH step-turtle 90 turn-right ; + +:: strafe-right ( TURTLE LENGTH -- turtle ) + TURTLE 90 turn-right LENGTH step-turtle 90 turn-left ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: polygon ( vertices -- ) GL_POLYGON glBegin [ first3 glVertex3d ] each glEnd ; + +: start-polygon ( turtle -- turtle ) dup vertices>> delete-all ; + +: finish-polygon ( turtle -- turtle ) dup vertices>> polygon ; + +: polygon-vertex ( turtle -- turtle ) dup [ pos>> ] [ vertices>> ] bi push ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: record-vertex ( turtle -- turtle ) dup pos>> first3 glVertex3d ; + +: draw-forward ( turtle length -- turtle ) + GL_LINES glBegin [ record-vertex ] dip step-turtle record-vertex glEnd ; + +: move-forward ( turtle length -- turtle ) step-turtle polygon-vertex ; + +: sneak-forward ( turtle length -- turtle ) step-turtle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: scale-length ( turtle m -- turtle ) over length>> * >>length ; +: scale-angle ( turtle m -- turtle ) over angle>> * >>angle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: set-thickness ( turtle i -- turtle ) dup glLineWidth >>thickness ; + +: scale-thickness ( turtle m -- turtle ) + over thickness>> * 0.5 max set-thickness ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: color-table ( -- colors ) + { + T{ rgba f 0 0 0 1 } ! black + T{ rgba f 0.5 0.5 0.5 1 } ! grey + T{ rgba f 1 0 0 1 } ! red + T{ rgba f 1 1 0 1 } ! yellow + T{ rgba f 0 1 0 1 } ! green + T{ rgba f 0.25 0.88 0.82 1 } ! turquoise + T{ rgba f 0 0 1 1 } ! blue + T{ rgba f 0.63 0.13 0.94 1 } ! purple + T{ rgba f 0.00 0.50 0.00 1 } ! dark green + T{ rgba f 0.00 0.82 0.82 1 } ! dark turquoise + T{ rgba f 0.00 0.00 0.50 1 } ! dark blue + T{ rgba f 0.58 0.00 0.82 1 } ! dark purple + T{ rgba f 0.50 0.00 0.00 1 } ! dark red + T{ rgba f 0.25 0.25 0.25 1 } ! dark grey + T{ rgba f 0.75 0.75 0.75 1 } ! medium grey + T{ rgba f 1 1 1 1 } ! white + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : material-color ( color -- ) +! GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ; + +: material-color ( color -- ) + GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot color>raw 4array gl-material ; + +: set-color ( turtle i -- turtle ) + dup color-table nth dup gl-color material-color >>color ; + +: inc-color ( turtle -- turtle ) dup color>> 1 + set-color ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: save-turtle ( turtle -- turtle ) dup clone over saved>> push ; +: restore-turtle ( turtle -- turtle ) saved>> pop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: default-L-parser-values ( turtle -- turtle ) + 1 >>length 45 >>angle 1 >>thickness 2 >>color ; + +: L-parser-dialect ( -- commands ) + + { + { "+" [ dup angle>> turn-left ] } + { "-" [ dup angle>> turn-right ] } + { "&" [ dup angle>> pitch-down ] } + { "^" [ dup angle>> pitch-up ] } + { "<" [ dup angle>> roll-left ] } + { ">" [ dup angle>> roll-right ] } + + { "|" [ 180.0 rotate-y ] } + { "%" [ 180.0 rotate-z ] } + { "$" [ roll-until-horizontal ] } + + { "F" [ dup length>> draw-forward ] } + { "Z" [ dup length>> 2 / draw-forward ] } + { "f" [ dup length>> move-forward ] } + { "z" [ dup length>> 2 / move-forward ] } + { "g" [ dup length>> sneak-forward ] } + { "." [ polygon-vertex ] } + + { "[" [ save-turtle ] } + { "]" [ restore-turtle ] } + + { "{" [ start-polygon ] } + { "}" [ finish-polygon ] } + + { "/" [ 1.1 scale-length ] } ! double quote command in lparser + { "'" [ 0.9 scale-length ] } + { ";" [ 1.1 scale-angle ] } + { ":" [ 0.9 scale-angle ] } + { "?" [ 1.4 scale-thickness ] } + { "!" [ 0.7 scale-thickness ] } + + { "c" [ dup color>> 1 + color-table length mod set-color ] } + + } + ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: < gadget + camera display-list + commands axiom rules string ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: open-paren ( -- ch ) CHAR: ( ; +: close-paren ( -- ch ) CHAR: ) ; + +: open-paren? ( obj -- ? ) open-paren = ; +: close-paren? ( obj -- ? ) close-paren = ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: read-instruction ( STRING -- next rest ) + + { [ STRING length 1 > ] [ STRING second open-paren? ] } 0&& + [ STRING close-paren STRING index 1 + cut ] + [ STRING 1 cut ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: iterate-string-loop ( STRING RULES ACCUM -- ) + STRING empty? not + [ + STRING read-instruction + + [let | REST [ ] NEXT [ ] | + + NEXT 1 head RULES at NEXT or ACCUM push-all + + REST RULES ACCUM iterate-string-loop ] + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: iterate-string ( STRING RULES -- string ) + + [let | ACCUM [ STRING length 10 * ] | + + STRING RULES ACCUM iterate-string-loop + + ACCUM >string ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: interpret-string ( STRING COMMANDS -- ) + + STRING empty? not + [ + STRING read-instruction + + [let | REST [ ] NEXT [ ] | + + [let | COMMAND [ NEXT 1 head COMMANDS at ] | + + COMMAND + [ + NEXT length 1 = + [ COMMAND call ] + [ + NEXT 2 tail 1 head* string>number + COMMAND 1 tail* + call + ] + if + ] + when ] + + REST COMMANDS interpret-string ] + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: iterate-L-system-string ( L-SYSTEM -- ) + L-SYSTEM string>> + L-SYSTEM rules>> + iterate-string + L-SYSTEM (>>string) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: do-camera-look-at ( CAMERA -- ) + + [let | EYE [ CAMERA pos>> ] + FOCUS [ CAMERA clone 1 step-turtle pos>> ] + UP [ CAMERA clone 90 pitch-up 1 step-turtle pos>> CAMERA pos>> v- ] + | + + EYE FOCUS UP gl-look-at ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: generate-display-list ( L-SYSTEM -- ) + + L-SYSTEM find-gl-context + + L-SYSTEM display-list>> GL_COMPILE glNewList + + turtle + L-SYSTEM string>> + L-SYSTEM commands>> + interpret-string + drop + + glEndList ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: draw-gadget* ( L-SYSTEM -- ) + + black gl-clear + + GL_FLAT glShadeModel + + GL_PROJECTION glMatrixMode + glLoadIdentity + -1 1 -1 1 1.5 200 glFrustum + + GL_MODELVIEW glMatrixMode + + glLoadIdentity + + L-SYSTEM camera>> do-camera-look-at + + GL_FRONT_AND_BACK GL_LINE glPolygonMode + + ! draw axis + white gl-color GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd + + L-SYSTEM display-list>> glCallList ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: graft* ( L-SYSTEM -- ) + + L-SYSTEM find-gl-context + + 1 glGenLists L-SYSTEM (>>display-list) ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: pref-dim* ( L-SYSTEM -- dim ) { 400 400 } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: camera-left ( L-SYSTEM -- ) + L-SYSTEM camera>> 5 turn-left drop + L-SYSTEM relayout-1 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: with-camera ( L-SYSTEM QUOT -- ) + L-SYSTEM camera>> QUOT call drop + L-SYSTEM relayout-1 ; + + +H{ + { T{ key-down f f "LEFT" } [ [ 5 turn-left ] with-camera ] } + { T{ key-down f f "RIGHT" } [ [ 5 turn-right ] with-camera ] } + { T{ key-down f f "UP" } [ [ 5 pitch-down ] with-camera ] } + { T{ key-down f f "DOWN" } [ [ 5 pitch-up ] with-camera ] } + + { T{ key-down f f "a" } [ [ 1 step-turtle ] with-camera ] } + { T{ key-down f f "z" } [ [ -1 step-turtle ] with-camera ] } + + { + T{ key-down f f "x" } + [ + dup iterate-L-system-string + dup generate-display-list + dup relayout-1 + drop + ] + } + +} +set-gestures + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: L-system ( -- L-system ) + + new-gadget + + turtle 45 turn-left 45 pitch-up 5 step-turtle 180 turn-left >>camera ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 6416cb78b09c91cd8ccbd34c997c09be1bd1a5d4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 5 Jan 2009 04:12:27 -0600 Subject: [PATCH 31/53] Add 'abop-1' L-system model --- extra/L-system/models/abop-1/abop-1.factor | 29 ++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 extra/L-system/models/abop-1/abop-1.factor diff --git a/extra/L-system/models/abop-1/abop-1.factor b/extra/L-system/models/abop-1/abop-1.factor new file mode 100644 index 0000000000..45cc522470 --- /dev/null +++ b/extra/L-system/models/abop-1/abop-1.factor @@ -0,0 +1,29 @@ + +USING: accessors kernel ui L-system ; + +IN: L-system.models.abop-1 + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: abop-1 ( -- ) + + L-parser-dialect >>commands + + "c(12)FFAL" >>axiom + + { + { "A" "F[&'(.8)!BL]>(137)'!(.9)A" } + { "B" "F[-'(.8)!(.9)$CL]'!(.9)C" } + { "C" "F[+'(.8)!(.9)$BL]'!(.9)B" } + + { "L" "~c(8){+(30)f-(120)f-(120)f}" } + } + >>rules + + dup axiom>> >>string ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: main ( -- ) [ L-system abop-1 "L-system" open-window ] with-ui ; + +MAIN: main From a59271139c6c6bd043885c2e6ab84d741f484fba Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 14:58:38 +0100 Subject: [PATCH 32/53] FUEL: Index entries sorted and some improvements in other tags in help browser. --- misc/fuel/fuel-help.el | 1 + misc/fuel/fuel-markup.el | 25 +++++++++++++++---------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 7c165e5de7..ba3ff2b57d 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -176,6 +176,7 @@ (insert content) (fuel-markup--print content) (fuel-markup--insert-newline) + (delete-blank-lines) (fuel-help--cache-insert key (buffer-string))) (fuel-help--history-push key) (setq fuel-help--buffer-link key) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index a2c94d4f4a..319fb23b5a 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -180,6 +180,7 @@ (defun fuel-markup--insert-heading (txt &optional no-nl) (fuel-markup--insert-nl-if-nb) + (delete-blank-lines) (unless (bobp) (newline)) (fuel-markup--put-face txt 'fuel-font-lock-markup-heading) (fuel-markup--insert-string txt) @@ -239,7 +240,7 @@ (insert (cadr e)))) (defun fuel-markup--snippet (e) - (let ((snip (format "%s" (cdr e)))) + (let ((snip (format "%s" (cadr e)))) (insert (fuel-font-lock--factor-str snip)))) (defun fuel-markup--code (e) @@ -260,17 +261,15 @@ (fuel-markup--print (cons '$code (cdr e))) (newline)) -(defun fuel-markup--examples (e) - (fuel-markup--insert-heading "Examples") - (dolist (ex (cdr e)) - (fuel-markup--print ex) +(defun fuel-markup--example (e) + (fuel-markup--insert-newline) + (dolist (s (cdr e)) + (fuel-markup--snippet (list '$snippet s)) (newline))) -(defun fuel-markup--example (e) - (fuel-markup--snippet (list '$snippet (cadr e)))) - (defun fuel-markup--markup-example (e) - (fuel-markup--snippet (cons '$snippet (cadr e)))) + (fuel-markup--insert-newline) + (fuel-markup--snippet (cons '$snippet (cdr e)))) (defun fuel-markup--link (e) (let* ((link (nth 1 e)) @@ -301,7 +300,10 @@ "classes.intersection" "classes.predicate"))) (subs (fuel-eval--retort-result (fuel-eval--send/wait cmd 200)))) (when subs - (fuel-markup--print subs)))) + (let ((start (point)) + (sort-fold-case nil)) + (fuel-markup--print subs) + (sort-lines nil start (point)))))) (defun fuel-markup--vocab-link (e) (fuel-markup--insert-button (cadr e) (cadr e) 'vocab)) @@ -459,6 +461,9 @@ (defun fuel-markup--errors (e) (fuel-markup--elem-with-heading e "Errors")) +(defun fuel-markup--examples (e) + (fuel-markup--elem-with-heading e "Examples")) + (defun fuel-markup--notes (e) (fuel-markup--elem-with-heading e "Notes")) From 9ca81aed93bd6c89b6cde5bb1ad7fcbc8c5a24bb Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 15:30:07 +0100 Subject: [PATCH 33/53] FUEL: bogus key binding fixed --- misc/fuel/fuel-help.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index ba3ff2b57d..bb191eaa74 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -284,7 +284,7 @@ With prefix, the current page is deleted from history." (define-key map "h" 'fuel-help) (define-key map "k" 'fuel-help-kill-page) (define-key map "n" 'fuel-help-next) - (define-key map "l" 'fuel-help-last) + (define-key map "l" 'fuel-help-previous) (define-key map "p" 'fuel-help-previous) (define-key map "r" 'fuel-help-refresh) (define-key map (kbd "SPC") 'scroll-up) From ca0f944e04fa013860412848fe29702aeb9ce019 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 22:06:43 +0100 Subject: [PATCH 34/53] FUEL: Edit article command in help buffers. --- extra/fuel/fuel.factor | 10 ++-- misc/fuel/fuel-edit.el | 104 +++++++++++++++++++++++++++++++++++++++++ misc/fuel/fuel-help.el | 11 +++++ misc/fuel/fuel-mode.el | 69 +-------------------------- 4 files changed, 123 insertions(+), 71 deletions(-) create mode 100644 misc/fuel/fuel-edit.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 03896029f1..b5fc84dcf7 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -165,18 +165,22 @@ SYMBOL: :uses ! Edit locations : fuel-normalize-loc ( seq -- path line ) - dup length 1 > [ first2 [ (normalize-path) ] dip ] [ f ] if ; inline + [ dup length 0 > [ first (normalize-path) ] [ drop f ] if ] + [ dup length 1 > [ second ] [ drop 1 ] if ] bi ; -: fuel-get-edit-location ( defspec -- ) +: fuel-get-edit-location ( word -- ) where fuel-normalize-loc 2array fuel-eval-set-result ; inline : fuel-get-vocab-location ( vocab -- ) >vocab-link fuel-get-edit-location ; inline -: fuel-get-doc-location ( defspec -- ) +: fuel-get-doc-location ( word -- ) props>> "help-loc" swap at fuel-normalize-loc 2array fuel-eval-set-result ; +: fuel-get-article-location ( name -- ) + article loc>> fuel-normalize-loc 2array fuel-eval-set-result ; + ! Cross-references : fuel-word>xref ( word -- xref ) diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el new file mode 100644 index 0000000000..ab81f46684 --- /dev/null +++ b/misc/fuel/fuel-edit.el @@ -0,0 +1,104 @@ +;;; fuel-edit.el -- utilities for file editing + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Mon Jan 05, 2009 21:16 + +;;; Comentary: + +;; Locating and opening factor source and documentation files. + +;;; Code: + +(require 'fuel-completion) +(require 'fuel-eval) +(require 'fuel-base) + + +;;; Auxiliar functions: + +(defun fuel-edit--try-edit (ret) + (let* ((err (fuel-eval--retort-error ret)) + (loc (fuel-eval--retort-result ret))) + (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) + (error "Couldn't find edit location")) + (unless (file-readable-p (car loc)) + (error "Couldn't open '%s' for read" (car loc))) + (find-file-other-window (car loc)) + (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) + +(defun fuel-edit--read-vocabulary-name (refresh) + (let* ((vocabs (fuel-completion--vocabs refresh)) + (prompt "Vocabulary name: ")) + (if vocabs + (completing-read prompt vocabs nil t nil fuel-edit--vocab-history) + (read-string prompt nil fuel-edit--vocab-history)))) + +(defun fuel-edit--edit-article (name) + (let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t))) + (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) + + +;;; Editing commands: + +(defvar fuel-edit--word-history nil) +(defvar fuel-edit--vocab-history nil) + +(defun fuel-edit-vocabulary (&optional refresh vocab) + "Visits vocabulary file in Emacs. +When called interactively, asks for vocabulary with completion. +With prefix argument, refreshes cached vocabulary list." + (interactive "P") + (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh))) + (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) + (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) + +(defun fuel-edit-word (&optional arg) + "Asks for a word to edit, with completion. +With prefix, only words visible in the current vocabulary are +offered." + (interactive "P") + (let* ((word (fuel-completion--read-word "Edit word: " + nil + fuel-edit--word-history + arg)) + (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))) + (fuel-edit--try-edit (fuel-eval--send/wait cmd)))) + +(defun fuel-edit-word-at-point (&optional arg) + "Opens a new window visiting the definition of the word at point. +With prefix, asks for the word to edit." + (interactive "P") + (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point)) + (fuel-completion--read-word "Edit word: "))) + (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))) + (condition-case nil + (fuel-edit--try-edit (fuel-eval--send/wait cmd)) + (error (fuel-edit-vocabulary nil word))))) + +(defun fuel-edit-word-doc-at-point (&optional arg word) + "Opens a new window visiting the documentation file for the word at point. +With prefix, asks for the word to edit." + (interactive "P") + (let* ((word (or word + (and (not arg) (fuel-syntax-symbol-at-point)) + (fuel-completion--read-word "Edit word: "))) + (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))) + (condition-case nil + (fuel-edit--try-edit (fuel-eval--send/wait cmd)) + (error + (message "Documentation for '%s' not found" word) + (when (and (eq major-mode 'factor-mode) + (y-or-n-p (concat "No documentation found. " + "Do you want to open the vocab's " + "doc file? "))) + (find-file-other-window + (format "%s-docs.factor" + (file-name-sans-extension (buffer-file-name))))))))) + + +(provide 'fuel-edit) +;;; fuel-edit.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index bb191eaa74..d5f3181450 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -14,6 +14,7 @@ ;;; Code: +(require 'fuel-edit) (require 'fuel-eval) (require 'fuel-markup) (require 'fuel-autodoc) @@ -269,6 +270,15 @@ With prefix, the current page is deleted from history." (fuel-help-refresh)) (message "")) +(defun fuel-help-edit () + "Edit the current article or word help." + (interactive) + (let ((link (car fuel-help--buffer-link)) + (type (nth 2 fuel-help--buffer-link))) + (cond ((eq type 'word) (fuel-edit-word-doc-at-point nil link)) + ((member type '(article vocab)) (fuel-edit--edit-article link)) + (t (error "No document associated with this page"))))) + ;;;; Help mode map: @@ -281,6 +291,7 @@ With prefix, the current page is deleted from history." (define-key map "bb" 'fuel-help-display-bookmarks) (define-key map "bd" 'fuel-help-delete-bookmark) (define-key map "c" 'fuel-help-clean-history) + (define-key map "e" 'fuel-help-edit) (define-key map "h" 'fuel-help) (define-key map "k" 'fuel-help-kill-page) (define-key map "n" 'fuel-help-next) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index df06584fab..651cc323d0 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -24,6 +24,7 @@ (require 'fuel-stack) (require 'fuel-autodoc) (require 'fuel-font-lock) +(require 'fuel-edit) (require 'fuel-syntax) (require 'fuel-base) @@ -80,7 +81,6 @@ With prefix argument, ask for the file to run." (message "Compiling %s ... OK!" file) (message ""))) - (defun fuel-eval-region (begin end &optional arg) "Sends region to Fuel's listener for evaluation. Unless called with a prefix, switches to the compilation results @@ -131,75 +131,8 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) -(defun fuel--try-edit (ret) - (let* ((err (fuel-eval--retort-error ret)) - (loc (fuel-eval--retort-result ret))) - (when (or err (not loc) (not (listp loc)) (not (stringp (car loc)))) - (error "Couldn't find edit location for '%s'" word)) - (unless (file-readable-p (car loc)) - (error "Couldn't open '%s' for read" (car loc))) - (find-file-other-window (car loc)) - (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))) - -(defun fuel-edit-word-at-point (&optional arg) - "Opens a new window visiting the definition of the word at point. -With prefix, asks for the word to edit." - (interactive "P") - (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point)) - (fuel-completion--read-word "Edit word: "))) - (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))) - (condition-case nil - (fuel--try-edit (fuel-eval--send/wait cmd)) - (error (fuel-edit-vocabulary nil word))))) - -(defun fuel-edit-word-doc-at-point (&optional arg) - "Opens a new window visiting the documentation file for the word at point. -With prefix, asks for the word to edit." - (interactive "P") - (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point)) - (fuel-completion--read-word "Edit word: "))) - (cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))) - (condition-case nil - (fuel--try-edit (fuel-eval--send/wait cmd)) - (error (when (y-or-n-p (concat "No documentation found. " - "Do you want to open the vocab's " - "doc file? ")) - (find-file-other-window - (format "%s-docs.factor" - (file-name-sans-extension (buffer-file-name))))))))) - (defvar fuel-mode--word-history nil) -(defun fuel-edit-word (&optional arg) - "Asks for a word to edit, with completion. -With prefix, only words visible in the current vocabulary are -offered." - (interactive "P") - (let* ((word (fuel-completion--read-word "Edit word: " - nil - fuel-mode--word-history - arg)) - (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))) - (fuel--try-edit (fuel-eval--send/wait cmd)))) - -(defvar fuel--vocabs-prompt-history nil) - -(defun fuel--read-vocabulary-name (refresh) - (let* ((vocabs (fuel-completion--vocabs refresh)) - (prompt "Vocabulary name: ")) - (if vocabs - (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history) - (read-string prompt nil fuel--vocabs-prompt-history)))) - -(defun fuel-edit-vocabulary (&optional refresh vocab) - "Visits vocabulary file in Emacs. -When called interactively, asks for vocabulary with completion. -With prefix argument, refreshes cached vocabulary list." - (interactive "P") - (let* ((vocab (or vocab (fuel--read-vocabulary-name refresh))) - (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) - (fuel--try-edit (fuel-eval--send/wait cmd)))) - (defun fuel-show-callers (&optional arg) "Show a list of callers of word at point. With prefix argument, ask for word." From f623c46314614140585c9d8dda1611076d62d3d5 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 22:09:18 +0100 Subject: [PATCH 35/53] FUEL: Document edit command. --- misc/fuel/README | 1 + 1 file changed, 1 insertion(+) diff --git a/misc/fuel/README b/misc/fuel/README index 700996ba4f..396e83a009 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -96,6 +96,7 @@ beast. - h : help for word at point - a : find words containing given substring (M-x fuel-apropos) + - e : edit current article - ba : bookmark current page - bb : display bookmarks - bd : delete bookmark at point From bb774d61c80204f6dea9dd15e98f0efeb327e3b0 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 5 Jan 2009 23:29:26 +0100 Subject: [PATCH 36/53] FUEL: MEMO:: recognised in factor syntax. --- misc/fuel/fuel-syntax.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 036ac7cbd0..2c3de32d4f 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -1,6 +1,6 @@ ;;; fuel-syntax.el --- auxiliar definitions for factor code navigation. -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -48,7 +48,7 @@ "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "IN:" "INSTANCE:" "INTERSECTION:" - "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:" + "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:" "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" "TUPLE:" "t" "t?" "TYPEDEF:" @@ -103,7 +103,8 @@ (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") (defconst fuel-syntax--definition-starters-regex - (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "METHOD" ":" ""))) + (regexp-opt + '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" ""))) (defconst fuel-syntax--definition-start-regex (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) From 7b110b0bfd09b86e35b1c2388a85a908160795e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:32:08 -0600 Subject: [PATCH 37/53] Move 3each, 3map from compiler.utilities to sequences --- basis/compiler/utilities/utilities.factor | 8 ------- core/sequences/sequences-tests.factor | 20 ++++++++++++++-- core/sequences/sequences.factor | 28 ++++++++++++++++------- 3 files changed, 38 insertions(+), 18 deletions(-) diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index 1f488b3dde..e8082edb68 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -21,11 +21,3 @@ IN: compiler.utilities : map-flat ( seq quot -- seq' ) [ each ] flattening ; inline : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline - -: (3each) ( seq1 seq2 seq3 quot -- n quot' ) - [ [ [ length ] tri@ min min ] 3keep ] dip - '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline - -: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline - -: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index dcca525e2b..80352faf72 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -32,8 +32,8 @@ IN: sequences.tests [ 4 CHAR: o ] [ 3 "hello world" "aeiou" [ member? ] curry find-from ] unit-test -[ f ] [ 3 [ ] member? ] unit-test -[ f ] [ 3 [ 1 2 ] member? ] unit-test +[ f ] [ 3 [ ] member? ] unit-test +[ f ] [ 3 [ 1 2 ] member? ] unit-test [ t ] [ 1 [ 1 2 ] member? ] unit-test [ t ] [ 2 [ 1 2 ] member? ] unit-test @@ -55,6 +55,11 @@ IN: sequences.tests [ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test +[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test +[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test + +[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test + [ "hello world how are you" ] [ { "hello" "world" "how" "are" "you" } " " join ] unit-test @@ -261,3 +266,14 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ "a,b" ] [ "a" "b" "," glue ] unit-test [ "(abc)" ] [ "abc" "(" ")" surround ] unit-test + +[ "HELLO" ] [ + "HELLO" { -1 -1 -1 -1 -1 } { 2 2 2 2 2 2 } + [ * 2 + + ] 3map +] unit-test + +{ 3 1 } [ [ 3array ] 3map ] must-infer-as + +{ 3 0 } [ [ 3drop ] 3each ] must-infer-as + +[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test \ No newline at end of file diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 40a8892e8b..557a52c482 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2005, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel kernel.private slots.private math math.private math.order ; @@ -117,9 +117,9 @@ INSTANCE: integer immutable-sequence [ tuck [ nth-unsafe ] 2bi@ ] [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline -: (head) ( seq n -- from to seq ) 0 spin ; inline +: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline -: (tail) ( seq n -- from to seq ) over length rot ; inline +: (tail) ( seq n -- from to seq ) swap [ length ] keep ; inline : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline @@ -352,6 +352,10 @@ PRIVATE> : 2map-into ( seq1 seq2 quot into -- newseq ) [ (2each) ] dip collect ; inline +: (3each) ( seq1 seq2 seq3 quot -- n quot' ) + [ [ [ length ] tri@ min min ] 3keep ] dip + [ [ [ [ nth-unsafe ] curry ] tri@ tri ] 3curry ] dip compose ; inline + : finish-find ( i seq -- i elt ) over [ dupd nth-unsafe ] [ drop f ] if ; inline @@ -419,6 +423,12 @@ PRIVATE> : 2all? ( seq1 seq2 quot -- ? ) (2each) all-integers? ; inline +: 3each ( seq1 seq2 seq3 quot -- ) + (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- newseq ) + (3each) map ; inline + : find-from ( n seq quot -- i elt ) [ (find-integer) ] (find-from) ; inline @@ -494,10 +504,12 @@ PRIVATE> : last-index-from ( obj i seq -- n ) rot [ = ] curry find-last-from drop ; +: (indices) ( elt i obj accum -- ) + [ swap [ = ] dip ] dip [ push ] 2curry when ; inline + : indices ( obj seq -- indices ) - V{ } clone spin - [ rot = [ over push ] [ drop ] if ] - curry each-index ; + swap V{ } clone + [ [ (indices) ] 2curry each-index ] keep ; : nths ( indices seq -- seq' ) [ nth ] curry map ; @@ -566,7 +578,7 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; PRIVATE> : filter-here ( seq quot -- ) - 0 0 roll (filter-here) ; inline + swap [ 0 0 ] dip (filter-here) ; inline : delete ( elt seq -- ) [ = not ] with filter-here ; @@ -828,7 +840,7 @@ PRIVATE> : supremum ( seq -- n ) dup first [ max ] reduce ; -: sigma ( seq quot -- n ) 0 -rot [ rot slip + ] curry each ; inline +: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline From 7c6d86491b9bfdb478eed63be66ccee84e21727e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:32:28 -0600 Subject: [PATCH 38/53] Add .# to gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index f4334f3727..a7cbeeeef3 100644 --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,4 @@ logs work build-support/wordsize *.bak +.#* From 16cdedb838e68c18f6d9cbaca2882c2653353992 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:33:06 -0600 Subject: [PATCH 39/53] Update copyright year --- license.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/license.txt b/license.txt index 768c13c549..8f4f53585a 100644 --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright (C) 2003, 2008 Slava Pestov and friends. +Copyright (C) 2003, 2009 Slava Pestov and friends. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 4c25fef273697a1c9a692fe1908c1fb8f4529e08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 17:33:27 -0600 Subject: [PATCH 40/53] Remove extra/faq now that we don't need it anymore --- extra/faq/authors.txt | 1 - extra/faq/faq.factor | 113 ------------------------------------------ extra/faq/summary.txt | 1 - 3 files changed, 115 deletions(-) delete mode 100755 extra/faq/authors.txt delete mode 100644 extra/faq/faq.factor delete mode 100755 extra/faq/summary.txt diff --git a/extra/faq/authors.txt b/extra/faq/authors.txt deleted file mode 100755 index f990dd0ed2..0000000000 --- a/extra/faq/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor deleted file mode 100644 index 512817bc4d..0000000000 --- a/extra/faq/faq.factor +++ /dev/null @@ -1,113 +0,0 @@ -! Copyright (C) 2007 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: xml kernel sequences xml.utilities math xml.data -arrays assocs xml.generator xml.writer namespaces -make math.parser io accessors ; -IN: faq - -: find-after ( seq quot -- elem after ) - over [ find ] dip rot 1+ tail ; inline - -: tag-named*? ( tag name -- ? ) - assure-name swap tag-named? ; - -! Questions -TUPLE: q/a question answer ; -C: q/a - -: li>q/a ( li -- q/a ) - [ "br" tag-named*? not ] filter - [ "strong" tag-named*? ] find-after - [ children>> ] dip ; - -: q/a>li ( q/a -- li ) - [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep - answer>> append "li" build-tag* ; - -: xml>q/a ( xml -- q/a ) - [ "question" tag-named children>> ] keep - "answer" tag-named children>> ; - -: q/a>xml ( q/a -- xml ) - [ question>> "question" build-tag* ] keep - answer>> "answer" build-tag* - "\n" swap 3array "qa" build-tag* ; - -! Lists of questions -TUPLE: question-list title seq ; -C: question-list - -: xml>question-list ( list -- question-list ) - [ "title" swap at ] keep - children>> [ tag? ] filter [ xml>q/a ] map - ; - -: question-list>xml ( question-list -- list ) - [ seq>> [ q/a>xml "\n" swap 2array ] - map concat "list" build-tag* ] keep - title>> [ "title" pick set-at ] when* ; - -: html>question-list ( h3 ol -- question-list ) - [ [ children>string ] [ f ] if* ] dip - children-tags [ li>q/a ] map ; - -: question-list>h3 ( id question-list -- h3 ) - title>> [ - "h3" build-tag - swap number>string "id" pick set-at - ] [ drop f ] if* ; - -: question-list>html ( question-list start id -- h3/f ol ) - -rot [ [ question-list>h3 ] keep seq>> [ q/a>li ] map "ol" build-tag* ] dip - number>string "start" pick set-at - "margin-left: 5em" "style" pick set-at ; - -! Overall everything -TUPLE: faq header lists ; -C: faq - -: html>faq ( div -- faq ) - unclip swap { "h3" "ol" } [ tags-named ] with map - first2 [ f prefix ] dip [ html>question-list ] 2map ; - -: header, ( faq -- ) - dup header>> , - lists>> first 1 -1 question-list>html nip , ; - -: br, ( -- ) - "br" contained, nl, ; - -: toc-link, ( question-list number -- ) - number>string "#" prepend "href" swap 2array 1array - "a" swap [ title>> , ] tag*, br, ; - -: toc, ( faq -- ) - "div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [ - "strong" [ "The big questions" , ] tag, br, - lists>> rest dup length [ toc-link, ] 2each - ] tag*, ; - -: faq-sections, ( question-lists -- ) - unclip seq>> length 1+ dupd - [ seq>> length + ] accumulate nip - 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ; - -: faq>html ( faq -- div ) - "div" [ - dup header, - dup toc, - lists>> faq-sections, - ] make-xml ; - -: xml>faq ( xml -- faq ) - [ "header" tag-named children>string ] keep - "list" tags-named [ xml>question-list ] map ; - -: faq>xml ( faq -- xml ) - "faq" [ - "header" [ dup header>> , ] tag, - lists>> [ question-list>xml , nl, ] each - ] make-xml ; - -: read-write-faq ( xml-stream -- ) - read-xml xml>faq faq>html write-xml ; diff --git a/extra/faq/summary.txt b/extra/faq/summary.txt deleted file mode 100755 index c33f8cffeb..0000000000 --- a/extra/faq/summary.txt +++ /dev/null @@ -1 +0,0 @@ -The Factor FAQ From af49278d3fefc608afac4cc35e5037d1425184f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 18:12:34 -0600 Subject: [PATCH 41/53] Add 2tri* and 2tri@ combinators, clean up (3each), and fix failing unit test for 3map --- core/kernel/kernel-docs.factor | 42 ++++++++++++++++++++++++++-- core/kernel/kernel-tests.factor | 6 ++++ core/kernel/kernel.factor | 8 ++++++ core/sequences/sequences-docs.factor | 9 ------ core/sequences/sequences.factor | 27 ++++++++++-------- 5 files changed, 69 insertions(+), 23 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1404491d10..bac4048706 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -359,6 +359,17 @@ HELP: 2bi* } } ; +HELP: 2tri* +{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "p" { $quotation "( u v -- ... )" } } { "q" { $quotation "( w x -- ... )" } } { "r" { $quotation "( y z -- ... )" } } } +{ $description "Applies " { $snippet "p" } " to " { $snippet "u" } " and " { $snippet "v" } ", then applies " { $snippet "q" } " to " { $snippet "w" } " and " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] [ q ] [ r ] 2tri*" + "[ [ p ] 2dip q ] 2dip r" + } +} ; + HELP: tri* { $values { "x" object } { "y" object } { "z" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( y -- ... )" } } { "r" { $quotation "( z -- ... )" } } } { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." } @@ -418,6 +429,22 @@ HELP: tri@ } } ; +HELP: 2tri@ +{ $values { "u" object } { "v" object } { "w" object } { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( obj1 obj2 -- ... )" } } } +{ $description "Applies the quotation to " { $snippet "u" } " and " { $snippet "v" } ", then to " { $snippet "w" } " and " { $snippet "x" } ", and then to " { $snippet "y" } " and " { $snippet "z" } "." } +{ $examples + "The following two lines are equivalent:" + { $code + "[ p ] 2tri@" + "[ [ p ] 2dip p ] 2dip p" + } + "The following two lines are also equivalent:" + { $code + "[ p ] 2tri@" + "[ p ] [ p ] [ p ] 2tri*" + } +} ; + HELP: if { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." @@ -595,12 +622,20 @@ HELP: 2dip HELP: 3dip { $values { "x" object } { "y" object } { "z" object } { "quot" quotation } } -{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." } { $notes "The following are equivalent:" { $code "[ [ [ foo bar ] dip ] dip ] dip" } { $code "[ foo bar ] 3dip" } } ; +HELP: 4dip +{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } } +{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." } +{ $notes "The following are equivalent:" + { $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" } + { $code "[ foo bar ] 4dip" } +} ; + HELP: while { $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; @@ -735,7 +770,7 @@ $nl { $subsection "cleave-shuffle-equivalence" } ; ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "." +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." $nl "Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" { $code @@ -775,6 +810,7 @@ $nl { $subsection 2bi* } "Three quotations:" { $subsection tri* } +{ $subsection 2tri* } "Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" { $code "! First alternative; uses dip" @@ -793,6 +829,7 @@ $nl { $subsection 2bi@ } "Three quotations:" { $subsection tri@ } +{ $subsection 2tri@ } "A pair of utility words built from " { $link bi@ } ":" { $subsection both? } { $subsection either? } ; @@ -804,6 +841,7 @@ $nl { $subsection dip } { $subsection 2dip } { $subsection 3dip } +{ $subsection 4dip } "The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" { $subsection slip } { $subsection 2slip } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index eae225e543..7ebaaeb3a8 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -163,3 +163,9 @@ IN: kernel.tests [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors last-frame ] unit-test + +[ 10 2 3 4 5 ] [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test + +[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test + +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test \ No newline at end of file diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d4df6fa407..a8f9281760 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -79,6 +79,8 @@ DEFER: if : 3dip ( x y z quot -- x y z ) -roll 3slip ; +: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline + ! Keepers : keep ( x quot -- x ) over slip ; inline @@ -118,6 +120,9 @@ DEFER: if : 2bi* ( w x y z p q -- ) [ 2dip ] dip call ; inline +: 2tri* ( u v w x y z p q r -- ) + [ 4dip ] 2dip 2bi* ; inline + ! Appliers : bi@ ( x y quot -- ) dup bi* ; inline @@ -129,6 +134,9 @@ DEFER: if : 2bi@ ( w x y z quot -- ) dup 2bi* ; inline +: 2tri@ ( u v w y x z quot -- ) + dup dup 2tri* ; inline + ! Object protocol GENERIC: hashcode* ( depth obj -- code ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index b3df0b889f..9f18fd4e66 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1112,15 +1112,6 @@ HELP: virtual@ { "n'" integer } { "seq'" sequence } } { $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ; -HELP: 2change-each -{ $values - { "seq1" sequence } { "seq2" sequence } { "quot" quotation } } -{ $description "Calls the quotation on subsequent pairs of objects from the two input sequences. The resulting computation replaces the element in the first sequence." } -{ $examples { $example "USING: kernel math sequences prettyprint ;" - "{ 10 20 30 } dup { 60 70 80 } [ + ] 2change-each ." - "{ 70 90 110 }" -} } ; - HELP: 2map-reduce { $values { "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 557a52c482..91c9d52404 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -346,15 +346,19 @@ PRIVATE> [ over ] dip [ nth-unsafe ] 2bi@ ; inline : (2each) ( seq1 seq2 quot -- n quot' ) - [ [ min-length ] 2keep ] dip - [ [ 2nth-unsafe ] dip call ] 3curry ; inline + [ + [ min-length ] 2keep + [ 2nth-unsafe ] 2curry + ] dip compose ; inline -: 2map-into ( seq1 seq2 quot into -- newseq ) - [ (2each) ] dip collect ; inline +: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 ) + [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline : (3each) ( seq1 seq2 seq3 quot -- n quot' ) - [ [ [ length ] tri@ min min ] 3keep ] dip - [ [ [ [ nth-unsafe ] curry ] tri@ tri ] 3curry ] dip compose ; inline + [ + [ [ length ] tri@ min min ] 3keep + [ 3nth-unsafe ] 3curry + ] dip compose ; inline : finish-find ( i seq -- i elt ) over [ dupd nth-unsafe ] [ drop f ] if ; inline @@ -411,23 +415,22 @@ PRIVATE> [ -rot ] dip 2each ; inline : 2map-as ( seq1 seq2 quot exemplar -- newseq ) - [ 2over min-length ] dip - [ [ 2map-into ] keep ] new-like ; inline + [ (2each) ] dip map-as ; inline : 2map ( seq1 seq2 quot -- newseq ) pick 2map-as ; inline -: 2change-each ( seq1 seq2 quot -- ) - pick 2map-into ; inline - : 2all? ( seq1 seq2 quot -- ? ) (2each) all-integers? ; inline : 3each ( seq1 seq2 seq3 quot -- ) (3each) each ; inline +: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq ) + [ (3each) ] dip map-as ; inline + : 3map ( seq1 seq2 seq3 quot -- newseq ) - (3each) map ; inline + [ pick ] dip swap 3map-as ; inline : find-from ( n seq quot -- i elt ) [ (find-integer) ] (find-from) ; inline From 76dcfc6c2bb4eb290b5076574f010922ce1c42b3 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 6 Jan 2009 02:23:38 +0100 Subject: [PATCH 42/53] FUEL: New command fuel-help-vocab (v in help browser). --- misc/fuel/README | 1 + misc/fuel/fuel-help.el | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/misc/fuel/README b/misc/fuel/README index 396e83a009..14a9ca8b5d 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -95,6 +95,7 @@ beast. *** In the help browser: - h : help for word at point + - v : help for a vocabulary - a : find words containing given substring (M-x fuel-apropos) - e : edit current article - ba : bookmark current page diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index d5f3181450..4d16ca3cba 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -232,6 +232,11 @@ buffer." (interactive) (fuel-help--word-help)) +(defun fuel-help-vocab (vocab) + "Ask for a vocabulary name and show its help page." + (interactive (list (fuel-edit--read-vocabulary-name nil))) + (fuel-help--get-vocab vocab)) + (defun fuel-help-next (&optional forget-current) "Go to next page in help browser. With prefix, the current page is deleted from history." @@ -298,6 +303,7 @@ With prefix, the current page is deleted from history." (define-key map "l" 'fuel-help-previous) (define-key map "p" 'fuel-help-previous) (define-key map "r" 'fuel-help-refresh) + (define-key map "v" 'fuel-help-vocab) (define-key map (kbd "SPC") 'scroll-up) (define-key map (kbd "S-SPC") 'scroll-down) (define-key map "\M-." 'fuel-edit-word-at-point) From d815c0c048fe9e5a4cb2976b2de0cead25259c0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Jan 2009 23:39:29 -0600 Subject: [PATCH 43/53] Fix Farkup link escaping --- basis/farkup/farkup-tests.factor | 12 +++++++++++- basis/farkup/farkup.factor | 2 +- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 27911a8d13..aa9345e1d0 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: farkup kernel peg peg.ebnf tools.test namespaces ; +USING: farkup kernel peg peg.ebnf tools.test namespaces xml +urls.encoding assocs xml.utilities ; IN: farkup.tests relative-link-prefix off @@ -157,3 +158,12 @@ link-no-follow? off [ "

hello_world how are you today?\n

  • hello_world how are you today?

" ] [ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test + +: check-link-escaping ( string -- link ) + convert-farkup string>xml-chunk + "a" deep-tag-named "href" swap at url-decode ; + +[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test +[ "" ] [ "[[]]" check-link-escaping ] unit-test +[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test +[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test \ No newline at end of file diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 284d5758a3..1bfd420dd3 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -167,7 +167,7 @@ stand-alone } cond ; : escape-link ( href text -- href-esc text-esc ) - [ check-url escape-quoted-string ] dip escape-string ; + [ check-url ] dip escape-string ; : write-link ( href text -- ) escape-link From 956492447c97e56430b0adaf8ebfc8262b6cadb4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 6 Jan 2009 07:05:42 +0100 Subject: [PATCH 44/53] FUEL: $describe-vocab and child vocab lists implemented. --- extra/fuel/fuel.factor | 39 +++++++++++++++++++++++++++---- misc/fuel/fuel-edit.el | 2 +- misc/fuel/fuel-markup.el | 50 +++++++++++++++++++++++++++++----------- 3 files changed, 72 insertions(+), 19 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index b5fc84dcf7..1770f320eb 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -6,7 +6,7 @@ compiler.units continuations debugger definitions help help.crossref help.markup help.topics io io.pathnames io.streams.string kernel lexer make math math.order memoize namespaces parser quotations prettyprint sequences sets sorting source-files strings summary tools.crossref -tools.vocabs vectors vocabs vocabs.parser words ; +tools.vocabs tools.vocabs.browser vectors vocabs vocabs.parser words ; IN: fuel @@ -298,16 +298,45 @@ MEMO: fuel-find-word ( name -- word/f ) fuel-find-word [ [ auto-use? on (fuel-word-see) ] with-scope ] [ f ] if* fuel-eval-set-result ; inline +: fuel-vocab-help-row ( vocab -- element ) + [ vocab-name ] + [ dup summary " " append swap vocab-status-string append ] + bi 2array ; + +: fuel-vocab-help-root-heading ( root -- element ) + [ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ; + +SYMBOL: vocab-list + +: fuel-vocab-children-table ( vocabs -- element ) + [ fuel-vocab-help-row ] map vocab-list prefix ; + +: fuel-vocab-children ( assoc -- seq ) + [ + [ drop f ] [ + [ fuel-vocab-help-root-heading ] + [ fuel-vocab-children-table ] bi* + [ 2array ] [ drop f ] if* + ] if-empty + ] { } assoc>map [ ] filter ; + +: fuel-vocab-children-help ( name -- element ) + all-child-vocabs fuel-vocab-children ; + : (fuel-vocab-help) ( name -- element ) \ article swap dup >vocab-link [ - [ summary [ , ] [ "No summary available" , ] if* ] - [ drop \ $nl , ] - [ vocab-help article [ content>> % ] when* ] tri + { + [ summary [ , ] [ "No summary available" , ] if* ] + [ drop \ $nl , ] + [ vocab-help [ article content>> % ] when* ] + [ name>> fuel-vocab-children-help % ] + } cleave ] { } make 3array ; : fuel-vocab-help ( name -- ) - (fuel-vocab-help) fuel-eval-set-result ; inline + dup empty? [ fuel-vocab-children-help ] [ (fuel-vocab-help) ] if + fuel-eval-set-result ; inline : (fuel-index) ( seq -- seq ) [ [ >link name>> ] [ article-title ] bi 2array \ $subsection prefix ] map ; diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index ab81f46684..e5988d1392 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -34,7 +34,7 @@ (let* ((vocabs (fuel-completion--vocabs refresh)) (prompt "Vocabulary name: ")) (if vocabs - (completing-read prompt vocabs nil t nil fuel-edit--vocab-history) + (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history) (read-string prompt nil fuel-edit--vocab-history)))) (defun fuel-edit--edit-article (name) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 319fb23b5a..a251f35ddd 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -90,6 +90,7 @@ ($contract . fuel-markup--contract) ($curious . fuel-markup--curious) ($definition . fuel-markup--definition) + ($describe-vocab . fuel-markup--describe-vocab) ($description . fuel-markup--description) ($doc-path . fuel-markup--doc-path) ($emphasis . fuel-markup--emphasis) @@ -138,7 +139,8 @@ ($vocab-subsection . fuel-markup--vocab-subsection) ($vocabulary . fuel-markup--vocabulary) ($warning . fuel-markup--warning) - (article . fuel-markup--article))) + (article . fuel-markup--article) + (vocab-list . fuel-markup--vocab-list))) (make-variable-buffer-local (defvar fuel-markup--maybe-nl nil)) @@ -164,10 +166,11 @@ (defun fuel-markup--maybe-nl () (setq fuel-markup--maybe-nl (point))) -(defun fuel-markup--insert-newline (&optional justification) +(defun fuel-markup--insert-newline (&optional justification nosqueeze) (fill-region (save-excursion (beginning-of-line) (point)) (point) - (or justification 'left)) + (or justification 'left) + nosqueeze) (newline)) (defsubst fuel-markup--insert-nl-if-nb (&optional no-fill) @@ -314,6 +317,18 @@ (fuel-markup--vocab-link (list '$vocab-link link)) (insert " "))) +(defun fuel-markup--vocab-list (e) + (let ((rows (mapcar '(lambda (elem) + (list (list '$vocab-link (car elem)) (cadr elem))) + (cdr e)))) + (fuel-markup--table (cons '$table rows)))) + +(defun fuel-markup--describe-vocab (e) + (fuel-markup--insert-nl-if-nb) + (let* ((cmd `(:fuel* ((,(cadr e) fuel-vocab-help)) "fuel" t)) + (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (when res (fuel-markup--print res)))) + (defun fuel-markup--vocabulary (e) (fuel-markup--insert-heading "Vocabulary: " t) (fuel-markup--vocab-link (cons '$vocab-link (cdr e))) @@ -328,20 +343,29 @@ (defun fuel-markup--table (e) (fuel-markup--insert-newline) + (delete-blank-lines) (newline) - (let ((start (point)) - (col-delim "<~end-of-col~>") - (col-no (length (cadr e)))) + (let* ((table-time-before-update 0) + (table-time-before-reformat 0) + (start (point)) + (col-delim "<~end-of-col~>") + (col-no (length (cadr e))) + (width (/ (- (window-width) 10) col-no)) + (step 100) + (count 0) + (inst '(lambda () + (table-capture start (point) col-delim nil nil width col-no) + (goto-char (point-max)) + (table-recognize -1) + (newline) + (setq start (point))))) (dolist (row (cdr e)) (dolist (col row) (fuel-markup--print col) - (insert col-delim))) - (table-capture start (point) - col-delim nil nil - (/ (- (window-width) 10) col-no) col-no)) - (goto-char (point-max)) - (table-recognize -1) - (newline)) + (insert col-delim) + (setq count (1+ count)) + (when (zerop (mod count step)) (funcall inst)))) + (unless (zerop (mod count step)) (funcall inst)))) (defun fuel-markup--instance (e) (insert " an instance of ") From af7844383278c7677c44ad39e8a83679854b4241 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 6 Jan 2009 16:28:10 +0100 Subject: [PATCH 45/53] FUEL: Much faster and nicer table rendering. --- extra/fuel/fuel.factor | 4 +- misc/fuel/fuel-markup.el | 30 ++++--------- misc/fuel/fuel-table.el | 91 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+), 26 deletions(-) create mode 100644 misc/fuel/fuel-table.el diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 1770f320eb..e5397e8f0a 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -299,9 +299,7 @@ MEMO: fuel-find-word ( name -- word/f ) fuel-eval-set-result ; inline : fuel-vocab-help-row ( vocab -- element ) - [ vocab-name ] - [ dup summary " " append swap vocab-status-string append ] - bi 2array ; + [ vocab-status-string ] [ vocab-name ] [ summary ] tri 3array ; : fuel-vocab-help-root-heading ( root -- element ) [ "Children from " prepend ] [ "Other children" ] if* \ $heading swap 2array ; diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index a251f35ddd..067aac4c17 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -16,9 +16,9 @@ (require 'fuel-eval) (require 'fuel-font-lock) (require 'fuel-base) +(require 'fuel-table) (require 'button) -(require 'table) ;;; Customization: @@ -319,7 +319,9 @@ (defun fuel-markup--vocab-list (e) (let ((rows (mapcar '(lambda (elem) - (list (list '$vocab-link (car elem)) (cadr elem))) + (list (car elem) + (list '$vocab-link (cadr elem)) + (caddr elem))) (cdr e)))) (fuel-markup--table (cons '$table rows)))) @@ -345,27 +347,9 @@ (fuel-markup--insert-newline) (delete-blank-lines) (newline) - (let* ((table-time-before-update 0) - (table-time-before-reformat 0) - (start (point)) - (col-delim "<~end-of-col~>") - (col-no (length (cadr e))) - (width (/ (- (window-width) 10) col-no)) - (step 100) - (count 0) - (inst '(lambda () - (table-capture start (point) col-delim nil nil width col-no) - (goto-char (point-max)) - (table-recognize -1) - (newline) - (setq start (point))))) - (dolist (row (cdr e)) - (dolist (col row) - (fuel-markup--print col) - (insert col-delim) - (setq count (1+ count)) - (when (zerop (mod count step)) (funcall inst)))) - (unless (zerop (mod count step)) (funcall inst)))) + (fuel-table--insert + (mapcar '(lambda (row) (mapcar 'fuel-markup--print-str row)) (cdr e))) + (newline)) (defun fuel-markup--instance (e) (insert " an instance of ") diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el new file mode 100644 index 0000000000..6972851e51 --- /dev/null +++ b/misc/fuel/fuel-table.el @@ -0,0 +1,91 @@ +;;; fuel-table.el -- table creation + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Tue Jan 06, 2009 13:44 + +;;; Comentary: + +;; Utilities to insert ascii tables. + +;;; Code: + +(defun fuel-table--col-widths (rows) + (let* ((col-no (length (car rows))) + (available (- (window-width) 10 (* 2 col-no))) + (widths) + (c 0)) + (while (< c col-no) + (let ((width 0) + (av-width (/ available (- col-no c)))) + (dolist (row rows) + (setq width (min av-width + (max width (length (nth c row)))))) + (push width widths) + (setq available (- available width))) + (setq c (1+ c))) + (reverse widths))) + +(defsubst fuel-table--pad-str (str width) + (if (>= (length str) width) + str + (concat str (make-string (- width (length str)) ?\ )))) + +(defun fuel-table--str-lines (str width) + (if (<= (length str) width) + (list (fuel-table--pad-str str width)) + (with-temp-buffer + (let ((fill-column width)) + (insert str) + (fill-region (point-min) (point-max)) + (mapcar '(lambda (s) (fuel-table--pad-str s width)) + (split-string (buffer-string) "\n")))))) + +(defun fuel-table--pad-row (row) + (let* ((max-ln (apply 'max (mapcar 'length row))) + (result)) + (dolist (lines row) + (let ((ln (length lines))) + (if (= ln max-ln) (push lines result) + (let ((lines (reverse lines)) + (l 0) + (blank (make-string (length (car lines)) ?\ ))) + (while (< l ln) + (push blank lines) + (setq l (1+ l))) + (push (reverse lines) result))))) + (reverse result))) + +(defun fuel-table--format-rows (rows widths) + (let ((col-no (length (car rows))) + (frows)) + (dolist (row rows) + (let ((c 0) (frow)) + (while (< c col-no) + (push (fuel-table--str-lines (nth c row) (nth c widths)) frow) + (setq c (1+ c))) + (push (fuel-table--pad-row (reverse frow)) frows))) + (reverse frows))) + +(defun fuel-table--insert (rows) + (let* ((widths (fuel-table--col-widths rows)) + (rows (fuel-table--format-rows rows widths)) + (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+"))) + (insert ls "\n") + (dolist (r rows) + (let ((ln (length (car r))) + (l 0)) + (while (< l ln) + (insert (concat "|" (mapconcat 'identity + (mapcar `(lambda (x) (nth ,l x)) r) + " |") + " |\n")) + (setq l (1+ l)))) + (insert ls "\n")))) + + +(provide 'fuel-table) +;;; fuel-table.el ends here From efcd8cb194be705dd8691a1be21fd2361978d9e3 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 6 Jan 2009 23:08:33 +0100 Subject: [PATCH 46/53] FUEL: Tags and authors support in help browser. --- extra/fuel/fuel.factor | 21 +++++++++++++++++-- misc/fuel/fuel-help.el | 24 +++++++++++++++++++++- misc/fuel/fuel-markup.el | 44 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 85 insertions(+), 4 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index e5397e8f0a..0cb19ad0eb 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -319,13 +319,15 @@ SYMBOL: vocab-list ] { } assoc>map [ ] filter ; : fuel-vocab-children-help ( name -- element ) - all-child-vocabs fuel-vocab-children ; + all-child-vocabs fuel-vocab-children ; inline : (fuel-vocab-help) ( name -- element ) \ article swap dup >vocab-link [ { - [ summary [ , ] [ "No summary available" , ] if* ] + [ vocab-authors [ \ $authors prefix , ] when* ] + [ vocab-tags [ \ $tags prefix , ] when* ] + [ summary [ { $heading "Summary" } swap 2array , ] when* ] [ drop \ $nl , ] [ vocab-help [ article content>> % ] when* ] [ name>> fuel-vocab-children-help % ] @@ -342,6 +344,21 @@ SYMBOL: vocab-list : fuel-index ( quot: ( -- seq ) -- ) call (fuel-index) fuel-eval-set-result ; inline +MEMO: (fuel-get-vocabs/author) ( author -- element ) + [ "Vocabularies by " prepend \ $heading swap 2array ] + [ authored fuel-vocab-children ] bi 2array ; + +: fuel-get-vocabs/author ( author -- ) + (fuel-get-vocabs/author) fuel-eval-set-result ; + +MEMO: (fuel-get-vocabs/tag ( tag -- element ) + [ "Vocabularies tagged " prepend \ $heading swap 2array ] + [ tagged fuel-vocab-children ] bi 2array ; + +: fuel-get-vocabs/tag ( tag -- ) + (fuel-get-vocabs/tag fuel-eval-set-result ; + + ! -run=fuel support : fuel-startup ( -- ) "listener" run-file ; inline diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 4d16ca3cba..d9e983d737 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -146,7 +146,7 @@ (message "")))) (defun fuel-help--get-vocab (name) - (message "Retrieving vocabulary help ...") + (message "Retrieving help vocabulary for vocabulary '%s' ..." name) (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) (ret (fuel-eval--send/wait cmd 2000)) (res (fuel-eval--retort-result ret))) @@ -155,6 +155,26 @@ (fuel-help--insert-contents (list name name 'vocab) res) (message "")))) +(defun fuel-help--get-vocab/author (author) + (message "Retrieving vocabularies by %s ..." author) + (let* ((cmd `(:fuel* ((,author fuel-get-vocabs/author)) "fuel" t)) + (ret (fuel-eval--send/wait cmd)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No vocabularies by %s" author) + (fuel-help--insert-contents (list author author 'author) res) + (message "")))) + +(defun fuel-help--get-vocab/tag (tag) + (message "Retrieving vocabularies tagged '%s' ..." tag) + (let* ((cmd `(:fuel* ((,tag fuel-get-vocabs/tag)) "fuel" t)) + (ret (fuel-eval--send/wait cmd)) + (res (fuel-eval--retort-result ret))) + (if (not res) + (message "No vocabularies tagged '%s'" tag) + (fuel-help--insert-contents (list tag tag 'tag) res) + (message "")))) + (defun fuel-help--follow-link (link label type &optional no-cache) (let* ((llink (list link label type)) (cached (and (not no-cache) (fuel-help--cache-get llink)))) @@ -163,6 +183,8 @@ (cond ((eq type 'word) (fuel-help--word-help nil link)) ((eq type 'article) (fuel-help--get-article link label)) ((eq type 'vocab) (fuel-help--get-vocab link)) + ((eq type 'author) (fuel-help--get-vocab/author label)) + ((eq type 'tag) (fuel-help--get-vocab/tag label)) ((eq type 'bookmarks) (fuel-help-display-bookmarks)) (t (error "Links of type %s not yet implemented" type)))) (fuel-help--insert-contents llink cached)))) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 067aac4c17..8a32bf8cf1 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -84,7 +84,11 @@ ;;; Markup printers: (defconst fuel-markup--printers - '(($class-description . fuel-markup--class-description) + '(($all-tags . fuel-markup--all-tags) + ($all-authors . fuel-markup--all-authors) + ($author . fuel-markup--author) + ($authors . fuel-markup--authors) + ($class-description . fuel-markup--class-description) ($code . fuel-markup--code) ($command . fuel-markup--command) ($contract . fuel-markup--contract) @@ -129,6 +133,8 @@ ($synopsis . fuel-markup--synopsis) ($syntax . fuel-markup--syntax) ($table . fuel-markup--table) + ($tag . fuel-markup--tag) + ($tags . fuel-markup--tags) ($unchecked-example . fuel-markup--example) ($value . fuel-markup--value) ($values . fuel-markup--values) @@ -336,6 +342,42 @@ (fuel-markup--vocab-link (cons '$vocab-link (cdr e))) (newline)) +(defun fuel-markup--tag (e) + (fuel-markup--link (list '$link (cadr e) (cadr e) 'tag))) + +(defun fuel-markup--tags (e) + (when (cdr e) + (fuel-markup--insert-heading "Tags: " t) + (dolist (tag (cdr e)) + (fuel-markup--tag (list '$tag tag)) + (insert ", ")) + (delete-backward-char 2) + (fuel-markup--insert-newline))) + +(defun fuel-markup--all-tags (e) + (let* ((cmd `(:fuel* (all-tags :get) "fuel" t)) + (tags (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (fuel-markup--list + (cons '$list (mapcar (lambda (tag) (list '$link tag tag 'tag)) tags))))) + +(defun fuel-markup--author (e) + (fuel-markup--link (list '$link (cadr e) (cadr e) 'author))) + +(defun fuel-markup--authors (e) + (when (cdr e) + (fuel-markup--insert-heading "Authors: " t) + (dolist (a (cdr e)) + (fuel-markup--author (list '$author a)) + (insert ", ")) + (delete-backward-char 2) + (fuel-markup--insert-newline))) + +(defun fuel-markup--all-authors (e) + (let* ((cmd `(:fuel* (all-authors :get) "fuel" t)) + (authors (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (fuel-markup--list + (cons '$list (mapcar (lambda (a) (list '$link a a 'author)) authors))))) + (defun fuel-markup--list (e) (fuel-markup--insert-nl-if-nb) (dolist (elt (cdr e)) From b8793abeeaf471234ef6d52e2afa3390fb9d64f0 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 7 Jan 2009 01:44:45 +0100 Subject: [PATCH 47/53] FUEL: Vocab word lists in help browser. --- extra/fuel/fuel.factor | 17 ++++++----- misc/fuel/fuel-markup.el | 62 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 7 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 0cb19ad0eb..add0941807 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -306,20 +306,23 @@ MEMO: fuel-find-word ( name -- word/f ) SYMBOL: vocab-list -: fuel-vocab-children-table ( vocabs -- element ) +: fuel-vocab-help-table ( vocabs -- element ) [ fuel-vocab-help-row ] map vocab-list prefix ; -: fuel-vocab-children ( assoc -- seq ) +: fuel-vocab-list ( assoc -- seq ) [ [ drop f ] [ [ fuel-vocab-help-root-heading ] - [ fuel-vocab-children-table ] bi* + [ fuel-vocab-help-table ] bi* [ 2array ] [ drop f ] if* ] if-empty ] { } assoc>map [ ] filter ; : fuel-vocab-children-help ( name -- element ) - all-child-vocabs fuel-vocab-children ; inline + all-child-vocabs fuel-vocab-list ; inline + +: fuel-vocab-describe-words ( name -- element ) + [ describe-words ] with-string-writer \ describe-words swap 2array ; inline : (fuel-vocab-help) ( name -- element ) \ article swap dup >vocab-link @@ -328,7 +331,7 @@ SYMBOL: vocab-list [ vocab-authors [ \ $authors prefix , ] when* ] [ vocab-tags [ \ $tags prefix , ] when* ] [ summary [ { $heading "Summary" } swap 2array , ] when* ] - [ drop \ $nl , ] + [ name>> fuel-vocab-describe-words , ] [ vocab-help [ article content>> % ] when* ] [ name>> fuel-vocab-children-help % ] } cleave @@ -346,14 +349,14 @@ SYMBOL: vocab-list MEMO: (fuel-get-vocabs/author) ( author -- element ) [ "Vocabularies by " prepend \ $heading swap 2array ] - [ authored fuel-vocab-children ] bi 2array ; + [ authored fuel-vocab-list ] bi 2array ; : fuel-get-vocabs/author ( author -- ) (fuel-get-vocabs/author) fuel-eval-set-result ; MEMO: (fuel-get-vocabs/tag ( tag -- element ) [ "Vocabularies tagged " prepend \ $heading swap 2array ] - [ tagged fuel-vocab-children ] bi 2array ; + [ tagged fuel-vocab-list ] bi 2array ; : fuel-get-vocabs/tag ( tag -- ) (fuel-get-vocabs/tag fuel-eval-set-result ; diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 8a32bf8cf1..b06fb6a77f 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -91,6 +91,7 @@ ($class-description . fuel-markup--class-description) ($code . fuel-markup--code) ($command . fuel-markup--command) + ($command-map . fuel-markup--null) ($contract . fuel-markup--contract) ($curious . fuel-markup--curious) ($definition . fuel-markup--definition) @@ -146,6 +147,7 @@ ($vocabulary . fuel-markup--vocabulary) ($warning . fuel-markup--warning) (article . fuel-markup--article) + (describe-words . fuel-markup--describe-words) (vocab-list . fuel-markup--vocab-list))) (make-variable-buffer-local @@ -342,6 +344,64 @@ (fuel-markup--vocab-link (cons '$vocab-link (cdr e))) (newline)) +(defun fuel-markup--parse-classes () + (let ((elems)) + (while (looking-at ".+ classes$") + (let ((heading `($heading ,(match-string-no-properties 0))) + (rows)) + (forward-line) + (when (looking-at "Class *.+$") + (push (split-string (match-string-no-properties 0) nil t) rows) + (forward-line)) + (while (not (looking-at "$")) + (let* ((objs (split-string (thing-at-point 'line) nil t)) + (class (list '$link (car objs) (car objs) 'word)) + (super (and (cadr objs) + (list (list '$link (cadr objs) (cadr objs) 'word)))) + (slots (when (cddr objs) + (list (mapcar '(lambda (s) (list s " ")) (cddr objs)))))) + (push `(,class ,@super ,@slots) rows)) + (forward-line)) + (push `(,heading ($table ,@(reverse rows))) elems)) + (forward-line)) + (reverse elems))) + +(defun fuel-markup--parse-words () + (let ((elems)) + (while (looking-at ".+ words\\|Primitives$") + (let ((heading `($heading ,(match-string-no-properties 0))) + (rows)) + (forward-line) + (when (looking-at "Word *Stack effect$") + (push '("Word" "Stack effect") rows) + (forward-line)) + (while (looking-at "\\(.+?\\) +\\(( .*\\)?$") + (let ((word `($link ,(match-string-no-properties 1) + ,(match-string-no-properties 1) + word)) + (se (and (match-string-no-properties 2) + `(($snippet ,(match-string-no-properties 2)))))) + (push `(,word ,@se) rows)) + (forward-line)) + (push `(,heading ($table ,@(reverse rows))) elems)) + (forward-line)) + (reverse elems))) + +(defun fuel-markup--parse-words-desc (desc) + (with-temp-buffer + (insert desc) + (goto-char (point-min)) + (when (re-search-forward "^Words$" nil t) + (forward-line 2) + (let ((elems '(($heading "Words")))) + (push (fuel-markup--parse-classes) elems) + (push (fuel-markup--parse-words) elems) + (reverse elems))))) + +(defun fuel-markup--describe-words (e) + (when (cadr e) + (fuel-markup--print (fuel-markup--parse-words-desc (cadr e))))) + (defun fuel-markup--tag (e) (fuel-markup--link (list '$link (cadr e) (cadr e) 'tag))) @@ -526,6 +586,8 @@ (fuel-markup--code (list '$code res)) (fuel-markup--snippet (list '$snippet word))))) +(defun fuel-markup--null (e)) + (defun fuel-markup--synopsis (e) (insert (format " %S " e))) From 03455ab7708168e750e18078acd90b929b9fd4b6 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 7 Jan 2009 01:59:15 +0100 Subject: [PATCH 48/53] FUEL: $operation. --- misc/fuel/fuel-markup.el | 1 + 1 file changed, 1 insertion(+) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index b06fb6a77f..f60f363061 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -116,6 +116,7 @@ ($methods . fuel-markup--methods) ($nl . fuel-markup--newline) ($notes . fuel-markup--notes) + ($operation . fuel-markup--link) ($parsing-note . fuel-markup--parsing-note) ($predicate . fuel-markup--predicate) ($prettyprinting-note . fuel-markup--prettyprinting-note) From 3ee5772c883026a5a1a1a329351b2ffcb9b1ac0d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 7 Jan 2009 02:47:44 +0100 Subject: [PATCH 49/53] FUEL: Shorten very long words in tables to keep delims aligned. --- misc/fuel/fuel-table.el | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el index 6972851e51..a00b21bf2f 100644 --- a/misc/fuel/fuel-table.el +++ b/misc/fuel/fuel-table.el @@ -15,24 +15,26 @@ (defun fuel-table--col-widths (rows) (let* ((col-no (length (car rows))) - (available (- (window-width) 10 (* 2 col-no))) + (available (- (window-width) 2 (* 2 col-no))) (widths) (c 0)) (while (< c col-no) (let ((width 0) - (av-width (/ available (- col-no c)))) + (av-width (- available (* 5 (- col-no c))))) (dolist (row rows) - (setq width (min av-width - (max width (length (nth c row)))))) + (setq width + (min av-width + (max width (length (nth c row)))))) (push width widths) (setq available (- available width))) (setq c (1+ c))) (reverse widths))) -(defsubst fuel-table--pad-str (str width) - (if (>= (length str) width) - str - (concat str (make-string (- width (length str)) ?\ )))) +(defun fuel-table--pad-str (str width) + (let ((len (length str))) + (cond ((= len width) str) + ((> len width) (concat (substring str 0 (- width 3)) "...")) + (t (concat str (make-string (- width (length str)) ?\ )))))) (defun fuel-table--str-lines (str width) (if (<= (length str) width) From 37760a0852d89185c687b75e5b0919b235400d4a Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 7 Jan 2009 03:03:20 +0100 Subject: [PATCH 50/53] FUEL: Fix for symbol words display in vocab help pages. --- misc/fuel/fuel-markup.el | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index f60f363061..69d1de8814 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -376,12 +376,12 @@ (when (looking-at "Word *Stack effect$") (push '("Word" "Stack effect") rows) (forward-line)) - (while (looking-at "\\(.+?\\) +\\(( .*\\)?$") + (while (looking-at "\\(.+?\\)\\( +\\(( .*\\)\\)?$") (let ((word `($link ,(match-string-no-properties 1) ,(match-string-no-properties 1) word)) - (se (and (match-string-no-properties 2) - `(($snippet ,(match-string-no-properties 2)))))) + (se (and (match-string-no-properties 3) + `(($snippet ,(match-string-no-properties 3)))))) (push `(,word ,@se) rows)) (forward-line)) (push `(,heading ($table ,@(reverse rows))) elems)) From 1a384e5e01db6792b4a52c196c25d1945a246b9d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Wed, 7 Jan 2009 04:08:36 +0100 Subject: [PATCH 51/53] FUEL: Tidbits. --- extra/fuel/fuel.factor | 3 ++- misc/fuel/fuel-help.el | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index add0941807..60420b3c39 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -331,8 +331,9 @@ SYMBOL: vocab-list [ vocab-authors [ \ $authors prefix , ] when* ] [ vocab-tags [ \ $tags prefix , ] when* ] [ summary [ { $heading "Summary" } swap 2array , ] when* ] - [ name>> fuel-vocab-describe-words , ] + [ drop \ $nl , ] [ vocab-help [ article content>> % ] when* ] + [ name>> fuel-vocab-describe-words , ] [ name>> fuel-vocab-children-help % ] } cleave ] { } make 3array ; diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index d9e983d737..705d1469a2 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -129,7 +129,7 @@ (let ((cmd `(:fuel* (,def ,(if see 'fuel-word-see 'fuel-word-help)) "fuel" t))) (message "Looking up '%s' ..." def) - (let* ((ret (fuel-eval--send/wait cmd 2000)) + (let* ((ret (fuel-eval--send/wait cmd)) (res (fuel-eval--retort-result ret))) (if (not res) (message "No help for '%s'" def) @@ -138,7 +138,7 @@ (defun fuel-help--get-article (name label) (message "Retrieving article ...") (let* ((cmd `(:fuel* ((,name fuel-get-article)) "fuel" t)) - (ret (fuel-eval--send/wait cmd 2000)) + (ret (fuel-eval--send/wait cmd)) (res (fuel-eval--retort-result ret))) (if (not res) (message "Article '%s' not found" label) @@ -148,7 +148,7 @@ (defun fuel-help--get-vocab (name) (message "Retrieving help vocabulary for vocabulary '%s' ..." name) (let* ((cmd `(:fuel* ((,name fuel-vocab-help)) "fuel" (,name))) - (ret (fuel-eval--send/wait cmd 2000)) + (ret (fuel-eval--send/wait cmd)) (res (fuel-eval--retort-result ret))) (if (not res) (message "No help available for vocabulary '%s'" name) From 70b6e1808c678adca033716569d9516574cfb690 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 6 Jan 2009 21:14:22 -0600 Subject: [PATCH 52/53] Clean up inverse a bit --- extra/inverse/inverse.factor | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index f1ca394e80..2feea39169 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -63,16 +63,20 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : enough? ( stack word -- ? ) dup deferred? [ 2drop f ] [ - [ [ length ] dip 1quotation infer in>> >= ] + [ [ length ] [ 1quotation infer in>> ] bi* >= ] [ 3drop f ] recover ] if ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ; + [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ; : fold ( quot -- folded-quot ) - [ { } swap [ fold-word ] each % ] [ ] make ; + [ { } [ fold-word ] reduce % ] [ ] make ; + +ERROR: no-recursive-inverse ; + +SYMBOL: visited : flattenable? ( object -- ? ) { [ word? ] [ primitive? not ] [ @@ -80,18 +84,18 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; [ word-prop ] with contains? not ] } 1&& ; -: (flatten) ( quot -- ) - [ dup flattenable? [ def>> (flatten) ] [ , ] if ] each ; - - : retain-stack-overflow? ( error -- ? ) - { "kernel-error" 14 f f } = ; - : flatten ( quot -- expanded ) - [ [ (flatten) ] [ ] make ] [ - dup retain-stack-overflow? - [ drop "No inverse defined on recursive word" ] when - throw - ] recover ; + [ + visited [ over suffix ] change + [ + dup flattenable? [ + def>> + [ visited get memq? [ no-recursive-inverse ] when ] + [ flatten ] + bi + ] [ 1quotation ] if + ] map concat + ] with-scope ; ERROR: undefined-inverse ; From 7f218dde57c34397457cf7ecbece3ec9613bee55 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Wed, 7 Jan 2009 11:05:53 -0600 Subject: [PATCH 53/53] fix typo in grouping docs, add more examples --- basis/grouping/grouping-docs.factor | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index e68c0ede1a..19560dfde2 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -29,8 +29,7 @@ ABOUT: "grouping" HELP: groups { $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively." $nl -"New groups are created by calling " { $link } " and " { $link } "." } -{ $see-also group } ; +"New groups are created by calling " { $link } " and " { $link } "." } ; HELP: group { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } @@ -48,11 +47,16 @@ HELP: "USING: arrays kernel prettyprint sequences grouping ;" "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }" } + { $example + "USING: kernel prettyprint sequences grouping ;" + "{ 1 2 3 4 5 6 } 3 0 swap nth ." + "{ 1 2 3 }" + } } ; HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } -{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } +{ $description "Outputs a virtual sequence whose elements are slices of disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example "USING: arrays kernel prettyprint sequences grouping ;" @@ -60,6 +64,11 @@ HELP: "dup [ reverse-here ] each concat >array ." "{ 2 1 0 5 4 3 8 7 6 }" } + { $example + "USING: kernel prettyprint sequences grouping ;" + "{ 1 2 3 4 5 6 } 3 1 swap nth ." + "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }" + } } ; HELP: clumps @@ -89,11 +98,23 @@ HELP: "share-price 4 [ [ sum ] [ length ] bi / ] map ." "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }" } + { $example + "USING: kernel sequences grouping prettyprint ;" + "{ 1 2 3 4 5 6 } 3 1 swap nth ." + "{ 2 3 4 }" + } } ; HELP: { $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } -{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ; +{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } +{ $examples + { $example + "USING: kernel sequences grouping prettyprint ;" + "{ 1 2 3 4 5 6 } 3 1 swap nth ." + "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }" + } +} ; { clumps groups } related-words