Merge commit 'littledan/master'
Slava Pestov
commit
36a1fb9bc3
|
|
@ -0,0 +1,113 @@
|
|||
! 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 ;
|
||||
|
||||
: read-write-faq ( xml-stream -- )
|
||||
[ read-xml ] with-stream xml>faq faq>html write-xml ;
|
||||
|
|
@ -18,13 +18,13 @@ 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
|
||||
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
|
||||
SYMBOL: special-complexes
|
||||
: special-complexes ( -- seq ) \ special-complexes get ;
|
||||
[
|
||||
{ -1 0 1 C{ 0 1 } C{ 0 -1 } } %
|
||||
e , e neg , pi , pi neg ,
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
USING: arrays assocs combinators.lib continuations kernel
|
||||
math math.functions memoize 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,78 +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) ;
|
||||
|
||||
|
||||
: builder-permutations ( n -- seq )
|
||||
{ [ compose ] [ swap curry ] } swap permutations
|
||||
[ concat ] map ; foldable
|
||||
|
||||
: all-quot-permutations ( seq -- newseq )
|
||||
dup length 1- builder-permutations
|
||||
swap [ 1quotation ] map dup length permutations
|
||||
[ swap [ >r seq>stack r> call ] curry* map ] curry* map ;
|
||||
|
||||
! clear { map sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
|
||||
! clear { map sq sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
|
||||
|
|
|
|||
Loading…
Reference in New Issue