From c8e63057a0029ca51d60703106b7b0fc29257819 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Sun, 9 Dec 2007 01:35:26 -0500
Subject: [PATCH 1/3] Minor random tester cleanup
---
extra/random-tester/random/random.factor | 27 +++-------
extra/random-tester/utils/utils.factor | 67 ++----------------------
2 files changed, 10 insertions(+), 84 deletions(-)
diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor
index da9a5c26d8..7b7b4dfb6e 100755
--- a/extra/random-tester/random/random.factor
+++ b/extra/random-tester/random/random.factor
@@ -1,22 +1,12 @@
-USING: kernel math sequences namespaces errors hashtables words
-arrays parser compiler syntax io tools prettyprint optimizer
-inference ;
+USING: kernel math sequences namespaces hashtables words math.functions
+arrays parser compiler syntax io random prettyprint optimizer layouts
+inference math.constants random-tester.utils ;
IN: random-tester
! Tweak me
: max-length 15 ; inline
: max-value 1000000000 ; inline
-: 10% ( -- bool ) 10 random 8 > ;
-: 20% ( -- bool ) 10 random 7 > ;
-: 30% ( -- bool ) 10 random 6 > ;
-: 40% ( -- bool ) 10 random 5 > ;
-: 50% ( -- bool ) 10 random 4 > ;
-: 60% ( -- bool ) 10 random 3 > ;
-: 70% ( -- bool ) 10 random 2 > ;
-: 80% ( -- bool ) 10 random 1 > ;
-: 90% ( -- bool ) 10 random 0 > ;
-
! varying bit-length random number
: random-bits ( n -- int )
random 2 swap ^ random ;
@@ -28,23 +18,20 @@ IN: random-tester
: random-string
[ max-length random [ max-value random , ] times ] "" make ;
-SYMBOL: special-integers
+: special-integers ( -- seq ) \ special-integers get ;
[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
{ } make \ special-integers set-global
-: special-integers ( -- seq ) \ special-integers get ;
-SYMBOL: special-floats
+: special-floats ( -- seq ) \ special-floats get ;
[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
{ } make \ special-floats set-global
-: special-floats ( -- seq ) \ special-floats get ;
-SYMBOL: special-complexes
+: special-complexes ( -- seq ) \ special-complexes get ;
[
- { -1 0 1 i -i } %
+ { -1 0 1 } % -1 sqrt dup , neg ,
e , e neg , pi , pi neg ,
0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
e neg e neg rect> , e e rect> ,
] { } make \ special-complexes set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
: random-fixnum ( -- fixnum )
most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ;
diff --git a/extra/random-tester/utils/utils.factor b/extra/random-tester/utils/utils.factor
index ef3d66ad2d..3bc8184e5e 100644
--- a/extra/random-tester/utils/utils.factor
+++ b/extra/random-tester/utils/utils.factor
@@ -1,7 +1,6 @@
USING: arrays assocs combinators.lib continuations kernel
math math.functions namespaces quotations random sequences
sequences.private shuffle ;
-
IN: random-tester.utils
: %chance ( n -- ? )
@@ -17,7 +16,7 @@ IN: random-tester.utils
: 80% ( -- ? ) 80 %chance ;
: 90% ( -- ? ) 90 %chance ;
-: call-if ( quot ? -- ) [ call ] [ drop ] if ; inline
+: call-if ( quot ? -- ) swap when ; inline
: with-10% ( quot -- ) 10% call-if ; inline
: with-20% ( quot -- ) 20% call-if ; inline
@@ -29,67 +28,7 @@ IN: random-tester.utils
: with-80% ( quot -- ) 80% call-if ; inline
: with-90% ( quot -- ) 90% call-if ; inline
-: random-hash-key keys random ;
-: random-hash-value [ random-hash-key ] keep at ;
+: random-key keys random ;
+: random-value [ random-key ] keep at ;
: do-one ( seq -- ) random call ; inline
-
-TUPLE: p-list seq max count count-vec ;
-
-: reset-array ( seq -- )
- [ drop 0 ] over map-into ;
-
-C: <p-list> p-list
-
-: make-p-list ( seq n -- tuple )
- >r dup length [ 1- ] keep r>
- [ ^ 0 swap 2array ] keep
- 0 <array> <p-list> ;
-
-: inc-seq ( seq max -- )
- 2dup [ < ] curry find-last over [
- nipd 1+ 2over swap set-nth
- 1+ over length rot <slice> reset-array
- ] [
- 3drop reset-array
- ] if ;
-
-: inc-count ( tuple -- )
- [ p-list-count first2 >r 1+ r> 2array ] keep
- set-p-list-count ;
-
-: (get-permutation) ( seq index-seq -- newseq )
- [ swap nth ] map-with ;
-
-: get-permutation ( tuple -- seq )
- [ p-list-seq ] keep p-list-count-vec (get-permutation) ;
-
-: p-list-next ( tuple -- seq/f )
- dup p-list-count first2 < [
- [
- [ get-permutation ] keep
- [ p-list-count-vec ] keep p-list-max
- inc-seq
- ] keep inc-count
- ] [
- drop f
- ] if ;
-
-: (permutations) ( tuple -- )
- dup p-list-next [ , (permutations) ] [ drop ] if* ;
-
-: permutations ( seq n -- seq )
- make-p-list [ (permutations) ] { } make ;
-
-: (each-permutation) ( tuple quot -- )
- over p-list-next [
- [ rot drop swap call ] 3keep
- drop (each-permutation)
- ] [
- 2drop
- ] if* ; inline
-
-: each-permutation ( seq n quot -- )
- >r make-p-list r> (each-permutation) ;
-
-
From d8c82ccacec8e717e7908f36e45d300eeb2e5711 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Mon, 10 Dec 2007 00:35:04 -0500
Subject: [PATCH 2/3] FAQ compilation
---
extra/faq/faq.factor | 110 +++++++++++++++++++++++++++++++++++++++++++
1 file changed, 110 insertions(+)
create mode 100644 extra/faq/faq.factor
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
new file mode 100644
index 0000000000..6d5f124157
--- /dev/null
+++ b/extra/faq/faq.factor
@@ -0,0 +1,110 @@
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml kernel sequences xml.utilities combinators.lib
+math xml.data arrays assocs xml.generator namespaces math.parser ;
+IN: faq
+
+: find-after ( seq quot -- elem after )
+ over >r find r> rot 1+ tail ; inline
+
+: tag-named? ( tag name -- ? )
+ assure-name swap (get-tag) ;
+
+! Questions
+TUPLE: q/a question answer ;
+C: <q/a> q/a
+
+: li>q/a ( li -- q/a )
+ [ "br" tag-named? not ] subset
+ [ "strong" tag-named? ] find-after
+ >r tag-children r> <q/a> ;
+
+: q/a>li ( q/a -- li )
+ [ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
+ q/a-answer append "li" build-tag* ;
+
+: xml>q/a ( xml -- q/a )
+ [ "question" tag-named tag-children ] keep
+ "answer" tag-named tag-children <q/a> ;
+
+: q/a>xml ( q/a -- xml )
+ [ q/a-question "question" build-tag* ] keep
+ q/a-answer "answer" build-tag*
+ "\n" swap 3array "qa" build-tag* ;
+
+! Lists of questions
+TUPLE: question-list title seq ;
+C: <question-list> question-list
+
+: xml>question-list ( list -- question-list )
+ [ "title" swap at ] keep
+ tag-children [ tag? ] subset [ xml>q/a ] map
+ <question-list> ;
+
+: question-list>xml ( question-list -- list )
+ [ question-list-seq [ q/a>xml "\n" swap 2array ]
+ map concat "list" build-tag* ] keep
+ question-list-title [ "title" pick set-at ] when* ;
+
+: html>question-list ( h3 ol -- question-list )
+ >r [ children>string ] [ f ] if* r>
+ children-tags [ li>q/a ] map <question-list> ;
+
+: question-list>h3 ( id question-list -- h3 )
+ question-list-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 >r [ question-list>h3 ] keep
+ question-list-seq [ q/a>li ] map "ol" build-tag* r>
+ number>string "start" pick set-at
+ "margin-left: 5em" "style" pick set-at ;
+
+! Overall everything
+TUPLE: faq header lists ;
+C: <faq> faq
+
+: html>faq ( div -- faq )
+ unclip swap { "h3" "ol" } [ tags-named ] curry* map
+ first2 >r f add* r> [ html>question-list ] 2map <faq> ;
+
+: header, ( faq -- )
+ dup faq-header ,
+ faq-lists first 1 -1 question-list>html nip , ;
+
+: br, ( -- )
+ "br" contained, nl, ;
+
+: toc-link, ( question-list number -- )
+ number>string "#" swap append "href" swap 2array 1array
+ "a" swap [ question-list-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,
+ faq-lists 1 tail dup length [ toc-link, ] 2each
+ ] tag*, ;
+
+: faq-sections, ( question-lists -- )
+ unclip question-list-seq length 1+ dupd
+ [ question-list-seq length + ] accumulate nip
+ 0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
+
+: faq>html ( faq -- div )
+ "div" [
+ dup header,
+ dup toc,
+ faq-lists faq-sections,
+ ] make-xml ;
+
+: xml>faq ( xml -- faq )
+ [ "header" tag-named children>string ] keep
+ "list" tags-named [ xml>question-list ] map <faq> ;
+
+: faq>xml ( faq -- xml )
+ "faq" [
+ "header" [ dup faq-header , ] tag,
+ faq-lists [ question-list>xml , nl, ] each
+ ] make-xml ;
From a290ea57cc2689b4ef3e0d89d81baca113417768 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Mon, 10 Dec 2007 00:37:32 -0500
Subject: [PATCH 3/3] FAQ convienence word
---
extra/faq/faq.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index 6d5f124157..703d542131 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -108,3 +108,6 @@ C: <faq> faq
"header" [ dup faq-header , ] tag,
faq-lists [ question-list>xml , nl, ] each
] make-xml ;
+
+: read-write-faq ( xml-stream -- )
+ [ read-xml ] with-stream xml>faq faq>html write-xml ;