diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor new file mode 100644 index 0000000000..703d542131 --- /dev/null +++ b/extra/faq/faq.factor @@ -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 + +: li>q/a ( li -- q/a ) + [ "br" tag-named? not ] subset + [ "strong" tag-named? ] find-after + >r tag-children r> ; + +: 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>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 + +: xml>question-list ( list -- question-list ) + [ "title" swap at ] keep + tag-children [ tag? ] subset [ xml>q/a ] map + ; + +: 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>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 + +: html>faq ( div -- faq ) + unclip swap { "h3" "ol" } [ tags-named ] curry* map + first2 >r f add* r> [ html>question-list ] 2map ; + +: 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>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 ; diff --git a/extra/random-tester/random/random.factor b/extra/random-tester/random/random.factor index 7cd669becf..163de69a59 100755 --- a/extra/random-tester/random/random.factor +++ b/extra/random-tester/random/random.factor @@ -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 , diff --git a/extra/random-tester/utils/utils.factor b/extra/random-tester/utils/utils.factor index 1c591a11e9..a025bbf45f 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 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 - -: make-p-list ( seq n -- tuple ) - >r dup length [ 1- ] keep r> - [ ^ 0 swap 2array ] keep - 0 ; - -: inc-seq ( seq max -- ) - 2dup [ < ] curry find-last over [ - nipd 1+ 2over swap set-nth - 1+ over length rot 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