├── 99bottles ├── 1 │ └── 1.factor ├── 2 │ └── 2.factor ├── 3 │ └── 3.factor └── 99bottles.factor ├── COPYRIGHT ├── LICENSE ├── README.md ├── accessors └── maybe │ ├── maybe-tests.factor │ └── maybe.factor ├── anybar └── anybar.factor ├── base256emoji └── base256emoji.factor ├── beer-advocate └── beer-advocate.factor ├── birthday └── birthday.factor ├── bitcoin-watcher └── bitcoin-watcher.factor ├── bowling ├── bowling-tests.factor └── bowling.factor ├── calc-ui ├── authors.txt ├── calc-ui.factor ├── calc-ui.png └── deploy.factor ├── calc ├── authors.txt ├── calc-docs.factor ├── calc-tests.factor ├── calc.factor └── summary.txt ├── cash-register └── cash-register.factor ├── cgi └── examples │ ├── brainfuck.factor │ ├── calc.factor │ ├── chloe.factor │ ├── debug.factor │ ├── fhtml.factor │ └── simple.factor ├── chemistry ├── chemistry-tests.factor └── chemistry.factor ├── cpu-speed └── cpu-speed.factor ├── cycles ├── cycles-tests.factor └── cycles.factor ├── daytime └── daytime.factor ├── derangements ├── derangements-tests.factor └── derangements.factor ├── desktop-picture ├── desktop-picture.factor ├── linux │ ├── linux.factor │ └── platforms.txt ├── macos │ ├── macos.factor │ └── platforms.txt └── windows │ ├── platforms.txt │ └── windows.factor ├── docs ├── cookbook.pdf ├── dls-talk.pdf ├── factor-articles.pdf ├── first-program.pdf ├── handbook.pdf ├── index.pdf ├── periodic_genius.jpg ├── system.pdf ├── tools.pdf └── visual-repl.txt ├── domainr └── domainr.factor ├── duckduckgo └── duckduckgo.factor ├── dupe ├── dupe.factor ├── dupe.go └── dupe.rb ├── emoji └── emoji.factor ├── euler └── euler.factor ├── facebook └── facebook.factor ├── factors └── factors.factor ├── fake-data ├── authors.txt └── fake-data.factor ├── fast-factorial ├── fast-factorial-tests.factor └── fast-factorial.factor ├── fast-fib ├── Makefile ├── fast-fib-tests.factor ├── fast-fib.factor ├── fib1.c ├── fib2.c └── fib3.c ├── fast-now ├── authors.txt ├── fast-now-tests.factor ├── fast-now.factor └── summary.txt ├── fast-pow ├── fast-pow-tests.factor └── fast-pow.factor ├── fizzbuzz ├── fizzbuzz-tests.factor └── fizzbuzz.factor ├── fortune ├── deploy.factor ├── fortune.factor └── summary.txt ├── friday-13th ├── friday-13th-tests.factor └── friday-13th.factor ├── gaddafi ├── gaddafi-tests.factor └── gaddafi.factor ├── geekcode ├── authors.txt ├── geekcode-tests.factor ├── geekcode.factor └── summary.txt ├── geo-tz ├── COPYING ├── geo-tz-tests.factor ├── geo-tz.factor ├── leaves.dat ├── zoom0.dat ├── zoom1.dat ├── zoom2.dat ├── zoom3.dat ├── zoom4.dat └── zoom5.dat ├── geonames └── geonames.factor ├── github ├── authors.txt ├── github.factor └── summary.txt ├── godel ├── godel-tests.factor └── godel.factor ├── google ├── buzz │ └── buzz.factor ├── google.factor └── translate │ ├── summary.txt │ └── translate.factor ├── haikunator └── haikunator.factor ├── hangman ├── hangman.factor └── words.txt ├── happy-numbers ├── happy-numbers-tests.factor └── happy-numbers.factor ├── harshad └── harshad.factor ├── hello-ga ├── authors.txt ├── hello-ga-tests.factor ├── hello-ga.factor └── summary.txt ├── help └── search │ └── search.factor ├── humanhash ├── humanhash-tests.factor └── humanhash.factor ├── icalendar └── icalendar.factor ├── ini-file-example ├── ini-file-example-tests.factor └── ini-file-example.factor ├── insults └── insults.factor ├── iphone-backup ├── address-book │ └── address-book.factor ├── bookmarks │ └── bookmarks.factor ├── calendar │ └── calendar.factor ├── iphone-backup.factor └── messages │ └── messages.factor ├── ipinfodb ├── authors.txt ├── ipinfodb-docs.factor ├── ipinfodb.factor └── summary.txt ├── isbn ├── isbn-tests.factor └── isbn.factor ├── js-arrays └── js-arrays.factor ├── k-nn ├── k-nn.factor ├── trainingsample.csv └── validationsample.csv ├── magic-forest ├── magic-forest.factor └── magic_forest.cpp ├── mail-ui └── mail-ui.factor ├── missing-assocs ├── authors.txt ├── missing-assocs-tests.factor └── missing-assocs.factor ├── misspell └── misspell.factor ├── monte-carlo └── monte-carlo.factor ├── mysql ├── authors.txt ├── errors │ └── errors.factor ├── ffi │ └── ffi.factor ├── lib │ └── lib.factor ├── mysql.factor └── summary.txt ├── n-numbers ├── n-numbers-tests.factor └── n-numbers.factor ├── n-partition ├── authors.txt ├── n-partition-docs.factor ├── n-partition-tests.factor ├── n-partition.factor └── summary.txt ├── pagination ├── pagination-tests.factor └── pagination.factor ├── palindrome ├── deploy.factor ├── palindrome-docs.factor ├── palindrome-tests.factor └── palindrome.factor ├── pdf └── examples │ └── examples.factor ├── periodic-words ├── periodic-words-tests.factor └── periodic-words.factor ├── pig-latin ├── pig-latin-tests.factor └── pig-latin.factor ├── plagiarism ├── deploy.factor ├── plagiarism-tests.factor └── plagiarism.factor ├── port-scan ├── authors.txt ├── port-scan.factor └── summary.txt ├── power-of-2 ├── Makefile ├── power-of-2.c └── power-of-2.factor ├── printf-example ├── printf-example-tests.factor └── printf-example.factor ├── pseudo-crypt ├── pseudo-crypt-tests.factor ├── pseudo-crypt.factor └── pseudo-crypt.py ├── psyng └── psyng.factor ├── random-names ├── bom-names.txt ├── country-names.txt ├── demon-names.txt ├── random-names.factor └── star-trek-races.txt ├── random-string ├── deploy.factor └── random-string.factor ├── re-factor └── re-factor.factor ├── reasoning ├── reasoning-tests.factor └── reasoning.factor ├── reference-server └── reference-server.factor ├── repopular └── repopular.factor ├── rgba-clock └── rgba-clock.factor ├── rock-paper-scissors ├── rock-paper-scissors-tests.factor └── rock-paper-scissors.factor ├── sanitize-paths ├── sanitize-paths-tests.factor └── sanitize-paths.factor ├── semver └── ebnf │ └── ebnf.factor ├── send-more-money └── send-more-money.factor ├── shortuuid ├── shortuuid-tests.factor └── shortuuid.factor ├── simple-rpg └── simple-rpg.factor ├── slot-machine ├── deploy.factor └── slot-machine.factor ├── sorting └── marriage │ ├── authors.txt │ ├── marriage-tests.factor │ ├── marriage.factor │ └── summary.txt ├── spark ├── spark-tests.factor └── spark.factor ├── speedtest └── speedtest.factor ├── square ├── square-tests.factor └── square.factor ├── subdomains ├── subdomains-tests.factor └── subdomains.factor ├── ta-lib ├── authors.txt ├── ffi │ └── ffi.factor └── ta-lib.factor ├── telnet-server └── telnet-server.factor ├── ten-ten └── ten-ten.factor ├── ternary-search-trees ├── ternary-search-tree.java ├── ternary-search-trees-tests.factor └── ternary-search-trees.factor ├── text-or-binary ├── text-or-binary-tests.factor └── text-or-binary.factor ├── text-summary └── text-summary.factor ├── tf-idf ├── authors.txt ├── stopwords.txt ├── summary.txt ├── tf-idf-tests.factor └── tf-idf.factor ├── thesaurus ├── thesaurus.dat └── thesaurus.factor ├── time-my-meeting └── time-my-meeting.factor ├── time ├── time-docs.factor └── time.factor ├── todos ├── todos-docs.factor └── todos.factor ├── transducers ├── transducers-tests.factor └── transducers.factor ├── utils ├── utils-docs.factor ├── utils-tests.factor └── utils.factor ├── vigenere ├── vigenere-tests.factor └── vigenere.factor ├── voting ├── voting-tests.factor └── voting.factor ├── wavsum ├── truck.wav ├── wavsum.c ├── wavsum.factor ├── wavsum.py └── wavsum.rb ├── wordcount ├── wordcount.factor ├── wordcount.py └── wordcount.rb ├── wordgen ├── wordgen-tests.factor └── wordgen.factor ├── wordle └── wordle.factor ├── worldcup └── worldcup.factor ├── wp └── wp.factor ├── xmode └── code2pdf │ └── code2pdf.factor └── yahoo └── finance └── finance.factor /99bottles/1/1.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: formatting io kernel math ranges sequences ; 5 | 6 | IN: 99bottles.1 7 | 8 | : verse ( n -- ) 9 | dup "%d bottles of beer on the wall, " printf 10 | dup "%d bottles of beer.\n" printf 11 | "Take one down and pass it around, " write 12 | 1 - "%d bottles of beer on the wall.\n" printf ; 13 | 14 | : last-verse ( -- ) 15 | "Go to the store and buy some more, " write 16 | "no more bottles of beer on the wall!" print ; 17 | 18 | : bottles ( n -- ) 19 | 1 [a..b] [ verse ] each last-verse ; 20 | -------------------------------------------------------------------------------- /99bottles/2/2.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: combinators formatting io kernel math ranges 5 | sequences ; 6 | 7 | IN: 99bottles.2 8 | 9 | : #bottles ( n -- str ) 10 | { 11 | { 1 [ "1 bottle" ] } 12 | { 0 [ "no more bottles" ] } 13 | [ "%d bottles" sprintf ] 14 | } case " of beer" append ; 15 | 16 | : verse ( n -- ) 17 | dup #bottles dup "%s on the wall, %s.\n" printf 18 | "Take one down and pass it around, " write 19 | 1 - #bottles "%s on the wall.\n" printf ; 20 | 21 | : verse-0 ( -- ) 22 | "No more bottles of beer on the wall, " write 23 | "no more bottles of beer." print 24 | "Go to the store and buy some more, " write 25 | "no more bottles of beer on the wall!" print ; 26 | 27 | : bottles ( n -- ) 28 | 1 [a..b] [ verse ] each verse-0 ; 29 | 30 | -------------------------------------------------------------------------------- /99bottles/3/3.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: combinators formatting io kernel math sequences ; 5 | 6 | IN: 99bottles.3 7 | 8 | : #bottles ( n -- str ) 9 | { 10 | { 1 [ "1 bottle" ] } 11 | { 0 [ "no more bottles" ] } 12 | [ "%d bottles" sprintf ] 13 | } case " of beer" append ; 14 | 15 | : on-the-wall ( n -- ) 16 | #bottles dup "%s on the wall, %s.\n" printf ; 17 | 18 | : take-one-down ( n -- ) 19 | "Take one down and pass it around, " write 20 | #bottles "%s on the wall.\n" printf ; 21 | 22 | : take-bottles ( n -- ) 23 | [ dup zero? ] [ 24 | [ on-the-wall ] [ 1 - dup take-one-down ] bi 25 | ] until on-the-wall ; 26 | 27 | : go-to-store ( n -- ) 28 | "Go to the store and buy some more, " write 29 | #bottles "%s on the wall.\n" printf ; 30 | 31 | : bottles ( n -- ) 32 | [ take-bottles ] [ go-to-store ] bi ; 33 | -------------------------------------------------------------------------------- /99bottles/99bottles.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: formatting io kernel math ranges sequences ; 5 | 6 | IN: 99bottles 7 | 8 | : verse ( n -- ) 9 | dup "%d bottles of beer on the wall, " printf 10 | dup "%d bottles of beer.\n" printf 11 | "Take one down and pass it around, " write 12 | 1 - "%d bottles of beer on the wall.\n" printf ; 13 | 14 | : verse-1 ( -- ) 15 | "1 bottle of beer on the wall, " write 16 | "1 bottle of beer." print 17 | "Take one down and pass it around, " write 18 | "no more bottles of beer on the wall." print ; 19 | 20 | : verse-0 ( -- ) 21 | "No more bottles of beer on the wall, " write 22 | "no more bottles of beer." print 23 | "Go to the store and buy some more, " write 24 | "99 bottles of beer on the wall." print ; 25 | 26 | : 99bottles ( -- ) 27 | 99 2 [a..b] [ verse ] each verse-1 verse-0 ; 28 | 29 | MAIN: 99bottles 30 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (C) 2008-2011 John Benediktsson 2 | See http://factorcode.org/license.txt for BSD license 3 | 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Redistribution and use in source and binary forms, with or without 2 | modification, are permitted provided that the following conditions are met: 3 | 4 | 1. Redistributions of source code must retain the above copyright notice, 5 | this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, 8 | this list of conditions and the following disclaimer in the documentation 9 | and/or other materials provided with the distribution. 10 | 11 | THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, 12 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 13 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 14 | DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 15 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 16 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 17 | OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 18 | WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 19 | OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 20 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 21 | 22 | -------------------------------------------------------------------------------- /accessors/maybe/maybe-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors accessors.maybe kernel tools.test ; 3 | 4 | IN: accessors.maybe 5 | 6 | << 7 | TUPLE: person name age ; 8 | person define-maybe-accessors 9 | >> 10 | 11 | [ "Frank" ] [ person new [ "Frank" ] maybe-name ] unit-test 12 | [ "Joe" ] [ "Joe" 20 person boa [ "Frank" ] maybe-name ] unit-test 13 | 14 | -------------------------------------------------------------------------------- /accessors/maybe/maybe.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors arrays kernel make quotations sequences 3 | slots words ; 4 | 5 | IN: accessors.maybe 6 | 7 | : maybe-word ( name -- word ) 8 | "maybe-" prepend "accessors" create-word ; 9 | 10 | : define-maybe ( name -- ) 11 | dup maybe-word dup deferred? [ 12 | [ 13 | over setter-word \ drop 2array >quotation 14 | [ keep ] curry , \ compose , 15 | swap reader-word [ dup ] swap 1quotation compose 16 | [ [ nip ] ] compose , \ dip , \ if* , 17 | ] [ ] make ( object quot: ( -- x ) -- value ) define-inline 18 | ] [ 2drop ] if ; 19 | 20 | : define-maybe-accessors ( class -- ) 21 | "slots" word-prop [ 22 | dup read-only>> [ drop ] [ name>> define-maybe ] if 23 | ] each ; 24 | 25 | ! << 26 | ! TUPLE: test a b c ; 27 | ! test define-maybe-accessors 28 | ! >> 29 | 30 | -------------------------------------------------------------------------------- /anybar/anybar.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2016 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: io.encodings.ascii io.encodings.string io.sockets 5 | namespaces sequences ; 6 | 7 | IN: anybar 8 | 9 | SYMBOL: anybar-host 10 | "localhost" anybar-host set-global 11 | 12 | SYMBOL: anybar-port 13 | 1738 anybar-port set-global 14 | 15 | : anybar ( str -- ) 16 | ascii encode 17 | anybar-host get resolve-host first 18 | anybar-port get with-port send-once ; 19 | -------------------------------------------------------------------------------- /base256emoji/base256emoji.factor: -------------------------------------------------------------------------------- 1 | USING: assocs literals sequences unicode ; 2 | 3 | IN: base256emoji 4 | 5 | emoji "🚀🪐☄🛰🌌🌑🌒🌓🌔🌕🌖🌗🌘🌍🌏🌎🐉☀💻🖥\ 9 | 💾💿😂❤😍🤣😊🙏💕😭😘👍😅👏😁🔥🥰💔💖💙😢🤔😆🙄💪😉☺👌🤗💜😔😎😇\ 10 | 🌹🤦🎉💞✌✨🤷😱😌🌸🙌😋💗💚😏💛🙂💓🤩😄😀🖤😃💯🙈👇🎶😒🤭❣😜💋\ 11 | 👀😪😑💥🙋😞😩😡🤪👊🥳😥🤤👉💃😳✋😚😝😴🌟😬🙃🍀🌷😻😓⭐✅🥺🌈😈\ 12 | 🤘💦✔😣🏃💐☹🎊💘😠☝😕🌺🎂🌻😐🖕💝🙊😹🗣💫💀👑🎵🤞😛🔴😤🌼😫⚽🤙\ 13 | ☕🏆🤫👈😮🙆🍻🍃🐶💁😲🌿🧡🎁⚡🌞🎈❌✊👋😰🤨😶🤝🚶💰🍓💢🤟🙁🚨💨\ 14 | 🤬✈🎀🍺🤓😙💟🌱😖👶🥴▶➡❓💎💸⬇😨🌚🦋😷🕺⚠🙅😟😵👎🤲🤠🤧📌🔵💅🧐\ 15 | 🐾🍒😗🤑🌊🤯🐷☎💧😯💆👆🎤🙇🍑❄🌴💣🐸💌📍🥀🤢👅💡💩👐📸👻🤐🤮🎼🥵\ 16 | 🚩🍎🍊👼💍📣🥂" 17 | >> 18 | 19 | CONSTANT: emoji>base256 $[ base256>emoji H{ } zip-index-as ] 20 | 21 | PRIVATE> 22 | 23 | : >base256emoji ( bytes -- str ) 24 | [ base256>emoji nth ] "" map-as ; 25 | 26 | : base256emoji> ( str -- bytes ) 27 | [ emoji>base256 at ] B{ } map-as ; 28 | -------------------------------------------------------------------------------- /birthday/birthday.factor: -------------------------------------------------------------------------------- 1 | #!/Users/jbenedik/Projects/factor/factor 2 | USING: fry io kernel sequences text-to-speech ; 3 | 4 | IN: birthday 5 | 6 | : sing ( name -- ) 7 | 4 swap '[ 8 | 2 = "dear " _ append "to You" ? 9 | "Happy Birthday " prepend 10 | [ write flush ] [ speak ] bi nl 11 | ] each ; 12 | 13 | : birthday ( -- ) 14 | "Who do you want to sing to? " write flush readln sing ; 15 | 16 | MAIN: birthday 17 | -------------------------------------------------------------------------------- /bowling/bowling-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: bowling tools.test ; 3 | 4 | IN: bowling.tests 5 | 6 | { 0 } [ "---------------------" bowl ] unit-test 7 | { 11 } [ "------------------X1-" bowl ] unit-test 8 | { 12 } [ "----------------X1-" bowl ] unit-test 9 | { 15 } [ "------------------5/5" bowl ] unit-test 10 | { 20 } [ "11111111111111111111" bowl ] unit-test 11 | { 20 } [ "5/5-----------------" bowl ] unit-test 12 | { 20 } [ "------------------5/X" bowl ] unit-test 13 | { 40 } [ "X5/5----------------" bowl ] unit-test 14 | { 80 } [ "-8-7714215X6172183-" bowl ] unit-test 15 | { 83 } [ "12X4--3-69/-98/8-8-" bowl ] unit-test 16 | { 150 } [ "5/5/5/5/5/5/5/5/5/5/5" bowl ] unit-test 17 | { 144 } [ "XXX6-3/819-44X6-" bowl ] unit-test 18 | { 266 } [ "XXXXXXXXX81-" bowl ] unit-test 19 | { 271 } [ "XXXXXXXXX9/2" bowl ] unit-test 20 | { 279 } [ "XXXXXXXXXX33" bowl ] unit-test 21 | { 295 } [ "XXXXXXXXXXX5" bowl ] unit-test 22 | { 300 } [ "XXXXXXXXXXXX" bowl ] unit-test 23 | { 100 } [ "-/-/-/-/-/-/-/-/-/-/-" bowl ] unit-test 24 | { 190 } [ "9/9/9/9/9/9/9/9/9/9/9" bowl ] unit-test 25 | -------------------------------------------------------------------------------- /bowling/bowling.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors arrays combinators formatting io kernel math 5 | math.statistics ranges sequences ; 6 | 7 | IN: bowling 8 | 9 | : pin ( last ch -- pin ) 10 | { 11 | { CHAR: - [ 0 ] } 12 | { CHAR: X [ 10 ] } 13 | { CHAR: / [ 10 over - ] } 14 | [ CHAR: 0 - ] 15 | } case nip ; 16 | 17 | : pins ( str -- pins ) 18 | f swap [ pin dup ] { } map-as nip ; 19 | 20 | : frame ( pins -- rest frame ) 21 | dup first 10 = 1 2 ? index-or-length cut-slice swap ; 22 | 23 | : frames ( pins -- frames ) 24 | 9 [ frame ] replicate swap suffix ; 25 | 26 | : bonus ( frame -- bonus ) 27 | [ seq>> ] [ to>> tail ] [ length 3 swap - ] tri head sum ; 28 | 29 | : scores ( frames -- scores ) 30 | [ [ sum ] keep over 10 = [ bonus + ] [ drop ] if ] map ; 31 | 32 | : bowl ( str -- score ) 33 | pins frames scores sum ; 34 | 35 | : bowl. ( str -- ) 36 | 10 [1..b] [ "%3d" sprintf ] map " | " join print 37 | 10 "---" "-+-" join print 38 | pins frames [ 39 | [ 40 | [ 41 | [ 42 | { 43 | { 0 [ CHAR: - ] } 44 | { 10 [ CHAR: X ] } 45 | [ CHAR: 0 + ] 46 | } case 47 | ] "" map-as 48 | ] [ 49 | dup length 1 > [ 50 | first2 + 10 = [ 51 | CHAR: / 1 pick set-nth 52 | ] when 53 | ] [ drop ] if 54 | ] bi "%3s" sprintf 55 | ] map " | " join print 56 | ] [ 57 | scores cum-sum 58 | [ "%3d" sprintf ] map " | " join print 59 | ] bi ; 60 | -------------------------------------------------------------------------------- /calc-ui/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /calc-ui/calc-ui.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/calc-ui/calc-ui.png -------------------------------------------------------------------------------- /calc-ui/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-name "calc-ui" } 4 | { deploy-ui? t } 5 | { deploy-c-types? f } 6 | { deploy-console? t } 7 | { deploy-unicode? f } 8 | { "stop-after-last-window?" t } 9 | { deploy-io 2 } 10 | { deploy-reflection 1 } 11 | { deploy-word-props? f } 12 | { deploy-math? t } 13 | { deploy-threads? t } 14 | { deploy-word-defs? f } 15 | } 16 | -------------------------------------------------------------------------------- /calc/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /calc/calc-docs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: help.syntax help.markup calc strings ; 5 | 6 | IN: calc 7 | 8 | HELP: calc 9 | { $values { "expression" string } } 10 | { $description 11 | "Calculates a mathematical expression." 12 | $nl 13 | "Operations:" 14 | { $table 15 | { "+" "add" } 16 | { "-" "subtract" } 17 | { "*" "multiply" } 18 | { "/" "divide" } 19 | { "%" "modulo" } 20 | { "^" "power" } 21 | { ">>" "right shift" } 22 | { "<<" "left shift" } 23 | } 24 | $nl 25 | "Functions:" 26 | { $table 27 | { "abs" } 28 | { "ceil" } 29 | { "cos" } 30 | { "cosh" } 31 | { "cot" } 32 | { "coth" } 33 | { "exp" } 34 | { "float" } 35 | { "floor" } 36 | { "int" } 37 | { "log" } 38 | { "log10" } 39 | { "round" } 40 | { "sin" } 41 | { "sinh" } 42 | { "sqrt" } 43 | { "tan" } 44 | { "tanh" } 45 | } 46 | } 47 | { $examples 48 | { $example 49 | "USING: calc ;" 50 | "\"2+3\" calc" 51 | "5" } 52 | { $example 53 | "USING: calc ;" 54 | "\"sin(3)\" calc" 55 | "0.1411200080598672" } 56 | { $example 57 | "USING: calc ;" 58 | "\"15+sqrt(2)\" calc" 59 | "16.4142135623731" } 60 | } ; 61 | 62 | -------------------------------------------------------------------------------- /calc/calc-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: calc math math.functions quotations tools.test ; 5 | 6 | IN: calc.tests 7 | 8 | [ "2" calc ] must-infer 9 | 10 | [ 2 ] [ "2" calc ] unit-test 11 | [ -2 ] [ "-2" calc ] unit-test 12 | 13 | [ 2.0 ] [ "2." calc ] unit-test 14 | [ -2.0 ] [ "-2." calc ] unit-test 15 | 16 | [ 2.3 ] [ "2.3" calc ] unit-test 17 | [ -2.3 ] [ "-2.3" calc ] unit-test 18 | 19 | 5 2 + 1quotation [ "5+2" calc ] unit-test 20 | 5 2 - 1quotation [ "5-2" calc ] unit-test 21 | 5 2 * 1quotation [ "5*2" calc ] unit-test 22 | 5 2 / 1quotation [ "5/2" calc ] unit-test 23 | 5 2 mod 1quotation [ "5%2" calc ] unit-test 24 | 5 2 ^ 1quotation [ "5^2" calc ] unit-test 25 | 5 2 shift 1quotation [ "5>>2" calc ] unit-test 26 | 5 -2 shift 1quotation [ "5<<2" calc ] unit-test 27 | 28 | 3 abs 1quotation [ "abs(3)" calc ] unit-test 29 | 3 ceiling 1quotation [ "ceil(3)" calc ] unit-test 30 | 3 cos 1quotation [ "cos(3)" calc ] unit-test 31 | 3 cosh 1quotation [ "cosh(3)" calc ] unit-test 32 | 3 cot 1quotation [ "cot(3)" calc ] unit-test 33 | 3 coth 1quotation [ "coth(3)" calc ] unit-test 34 | 3 e^ 1quotation [ "exp(3)" calc ] unit-test 35 | 3 >float 1quotation [ "float(3)" calc ] unit-test 36 | 3 floor 1quotation [ "floor(3)" calc ] unit-test 37 | 3 >fixnum 1quotation [ "int(3)" calc ] unit-test 38 | 3 log 1quotation [ "log(3)" calc ] unit-test 39 | 3 log10 1quotation [ "log10(3)" calc ] unit-test 40 | 3 round 1quotation [ "round(3)" calc ] unit-test 41 | 3 sin 1quotation [ "sin(3)" calc ] unit-test 42 | 3 sinh 1quotation [ "sinh(3)" calc ] unit-test 43 | 3 sqrt 1quotation [ "sqrt(3)" calc ] unit-test 44 | 3 tan 1quotation [ "tan(3)" calc ] unit-test 45 | 3 tanh 1quotation [ "tanh(3)" calc ] unit-test 46 | 47 | 2 3 sin + 5 cos + 1quotation [ "2+sin(3)+cos(5)" calc ] unit-test 48 | 49 | 50 | -------------------------------------------------------------------------------- /calc/summary.txt: -------------------------------------------------------------------------------- 1 | An infix DSL for calculator expressions. 2 | -------------------------------------------------------------------------------- /cash-register/cash-register.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2024 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: assocs command-loop formatting io kernel math 5 | math.functions math.parser namespaces sequences splitting ; 6 | 7 | IN: cash-register 8 | 9 | CONSTANT: COINS { 10 | { 50000 "$500" } 11 | { 10000 "$100" } 12 | { 5000 "$50" } 13 | { 2000 "$20" } 14 | { 1000 "$10" } 15 | { 500 "$5" } 16 | { 200 "$2" } 17 | { 100 "$1" } 18 | { 25 "quarters" } 19 | { 10 "dimes" } 20 | { 5 "nickels" } 21 | { 1 "pennies" } 22 | } 23 | 24 | : make-change ( n -- assoc ) 25 | COINS [ [ /mod swap ] dip ] assoc-map swap 0 assert= ; 26 | 27 | : $. ( n -- ) 28 | 100 /f "$%.2f\n" printf ; 29 | 30 | : change. ( n -- ) 31 | "CHANGE: " write dup $. 32 | make-change [ 33 | '[ _ "%d of %s\n" printf ] unless-zero 34 | ] assoc-each ; 35 | 36 | INITIALIZED-SYMBOL: owed [ 0 ] 37 | 38 | INITIALIZED-SYMBOL: paid [ 0 ] 39 | 40 | : balance. ( -- ) 41 | "OWED: " write owed get-global $. 42 | "PAID: " write paid get-global $. ; 43 | 44 | : charge ( n -- ) 45 | "CHARGE: " write dup $. 46 | owed [ + ] change-global balance. ; 47 | 48 | : pay ( n -- ) 49 | "PAY: " write dup $. 50 | paid [ + ] change-global balance. 51 | paid get-global owed get-global - dup 0 >= 52 | [ change. 0 owed set-global 0 paid set-global ] [ drop ] if ; 53 | 54 | : cancel ( -- ) 55 | "CANCEL" print 56 | 0 owed set-global 57 | paid [ change. 0 ] change-global ; 58 | 59 | : parse-$ ( args -- n ) 60 | "$" ?head drop string>number 100 * round >integer ; 61 | 62 | CONSTANT: COMMANDS { 63 | T{ command 64 | { name "balance" } 65 | { quot [ drop balance. ] } 66 | { help "Display current balance." } 67 | { abbrevs { "b" } } } 68 | T{ command 69 | { name "charge" } 70 | { quot [ parse-$ charge ] } 71 | { help "Charge an item." } 72 | { abbrevs { "c" } } } 73 | T{ command 74 | { name "pay" } 75 | { quot [ parse-$ pay ] } 76 | { help "Pay with money." } 77 | { abbrevs { "p" } } } 78 | T{ command 79 | { name "cancel" } 80 | { quot [ drop cancel ] } 81 | { help "Cancel transaction." } 82 | { abbrevs { "x" } } } 83 | } 84 | 85 | : cash-register-main ( -- ) 86 | "Welcome to the Cash Register!" "$>" 87 | command-loop new-command-loop 88 | COMMANDS [ over add-command ] each 89 | run-command-loop ; 90 | 91 | MAIN: cash-register-main 92 | -------------------------------------------------------------------------------- /cgi/examples/brainfuck.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | USING: assocs brainfuck cgi formatting io kernel ; 4 | 5 | "Content-type: text/html\n\n" write 6 | 7 | "code" at 8 | """ 9 | ++++++++++[>+++++++>++++++++++>+++>+<<<<-] 10 | >++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++. 11 | ------.--------.>+.>. 12 | """ or dup get-brainfuck 13 | 14 | """ 15 | 16 | Brainfuck 17 | 18 |
19 |
22 |   23 | 24 |
25 | 
26 | %s
27 |
28 | 29 | 30 | """ printf 31 | 32 | -------------------------------------------------------------------------------- /cgi/examples/calc.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | IN: calc 4 | 5 | USE: assocs 6 | USE: cgi 7 | USE: combinators 8 | USE: formatting 9 | USE: io 10 | USE: kernel 11 | USE: math 12 | USE: math.parser 13 | USE: namespaces 14 | USE: system 15 | 16 | system-micros "now" set 17 | 18 | "Content-type: text/html\n\n" write 19 | 20 | """ 21 | 22 | 23 | Calculator 24 | 25 | 26 | 27 |
28 | """ write 29 | 30 | : input-text ( value name size -- ) 31 | "" 32 | printf ; 33 | 34 | 35 | { 36 | [ "x" [ of "3" or ] keep 10 input-text ] 37 | [ "action" [ of "+" or ] keep 4 input-text ] 38 | [ "y" [ of "5" or ] keep 10 input-text ] 39 | [ " = " write drop ] 40 | [ "result" [ of "8" or ] keep 10 input-text ] 41 | } cleave 42 | 43 | """ 44 | 45 | 46 | 47 | 
48 | """ write
49 | 
50 | system-micros "now" get - 1000.0 / 
51 | number>string write " ms" write
52 | 
53 | """
54 |
55 | 56 | 57 | """ write 58 | 59 | -------------------------------------------------------------------------------- /cgi/examples/chloe.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | USE: io 4 | 5 | "Content-type: text/html\n\n" print 6 | 7 | USE: assocs 8 | USE: cgi 9 | USE: html.forms 10 | USE: html.templates.chloe 11 | USE: html.templates.chloe.compiler 12 | USE: kernel 13 | USE: multiline 14 | USE: sequences 15 | USE: splitting 16 | USE: xml 17 | 18 | """ 19 | 20 | 21 | Chloe 22 | 23 | 24 |
25 | "numbers" of "" or 31 | [ write ] 32 | [ "," split [ empty? ] reject "numbers" set-value ] bi 33 | 34 | """ 35 | "> 36 | 37 |
38 | """ print 39 | 40 | """ 41 | 42 | 43 |
    44 | 45 |
    • 46 |     47 |
48 | 49 | 50 | """ string>xml compile-template call( -- ) 51 | 52 | """ 53 | 54 | 55 | """ print 56 | 57 | 58 | -------------------------------------------------------------------------------- /cgi/examples/debug.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | USING: assocs environment kernel io namespaces 4 | sequences sorting ; 5 | 6 | "Content-type: text/html\n\n" print 7 | 8 | """ 9 | 10 | 11 | Debug 12 | 13 | 14 | 
15 | """ print
16 | 
17 | os-envs sort-keys [
18 |     [ "" write first write "" write ]
19 |     [ " = " write second write nl ] bi
20 | ] each
21 | 
22 | """
23 |
24 | 25 | 26 | """ print 27 | 28 | -------------------------------------------------------------------------------- /cgi/examples/fhtml.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | USE: io 4 | 5 | "Content-type: text/html\n\n" print 6 | 7 | USE: html.templates.fhtml 8 | 9 | """ 10 | <% USING: calendar formatting math math.parser io ; %> 11 | 12 | 13 | Simple Embedded Factor Example 14 | 15 | The time is <% now "%c" strftime write %>. 16 |
17 | <% 5 [ %>

I like repetition

<% ] times %> 18 | 19 | 20 | 21 | """ parse-template call( -- ) 22 | 23 | 24 | -------------------------------------------------------------------------------- /cgi/examples/simple.factor: -------------------------------------------------------------------------------- 1 | #! /Users/jbenedik/Projects/factor/factor 2 | 3 | USE: system 4 | USE: namespaces 5 | USE: math 6 | USE: math.parser 7 | 8 | system-micros "now" set 9 | 10 | USING: assocs cgi combinators kernel io multiline ; 11 | 12 | "Content-type: text/html\n\n" print 13 | 14 | """ 15 | 16 | 17 | Testing 18 | 25 | 26 | 27 | 28 | 29 | 
30 | """ print
31 | 
32 | USE: environment
33 | USE: sequences
34 | USE: sorting
35 | 
36 | os-envs sort-keys [
37 |     [ "" write first write "" write ]
38 |     [ " = " write second write nl ] bi
39 | ] each
40 | 
41 | """
42 |
43 | 44 |
45 | """ print 46 | 47 | USE: prettyprint 48 | 49 | 50 | { 51 | [ 52 | "" write 53 | "
" print 56 | ] 57 | [ 58 | "" write 59 | "
" print 61 | ] 62 | } cleave 63 | 64 | """ 65 | 66 | 67 | 68 | 
69 | """ print
70 | 
71 | system-micros "now" get - 1000.0 / 
72 | number>string write " ms" write
73 | 
74 | """
75 |
76 | 77 | 78 | """ print 79 | 80 | -------------------------------------------------------------------------------- /chemistry/chemistry-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel sequences tools.test ; 3 | IN: chemistry 4 | 5 | { t } [ 6 | { 7 | { "H" "H" } 8 | { "Pb" "Pb" } 9 | { "Pb2" "2Pb" } 10 | { "H2" "2H" } 11 | { "3Pb2" "6Pb" } 12 | { "Pb2SO4" "2Pb S 4O" } 13 | { "PbH2" "Pb 2H" } 14 | { "(PbH2)2" "2Pb 4H" } 15 | { "(CCC)2" "2C 2C 2C" } 16 | { "Pb(H2)2" "Pb 4H" } 17 | { "(Pb(H2)2)2" "2Pb 8H" } 18 | { "(Pb(H2)2)2NO3" "2Pb 8H N 3O" } 19 | { "(Ag(Pb(H2)2)2)2SO4" "2Ag 4Pb 16H S 4O" } 20 | { "Pb(CH3(CH2)2CH3)2" "Pb 2C 6H 4C 8H 2C 6H" } 21 | { "Na2(CH3(CH2)2CH3)2" "2Na 2C 6H 4C 8H 2C 6H" } 22 | { "Tc(H2O)3Fe3(SO4)2" "Tc 6H 3O 3Fe 2S 8O" } 23 | { "Tc(H2O)3(Fe3(SO4)2)2" "Tc 6H 3O 6Fe 4S 16O" } 24 | { "(Tc(H2O)3(Fe3(SO4)2)2)2" "2Tc 12H 6O 12Fe 8S 32O" } 25 | { 26 | "(Tc(H2O)3CO(Fe3(SO4)2)2)2" 27 | "2Tc 12H 6O 2C 2O 12Fe 8S 32O" 28 | } 29 | { 30 | "(Tc(H2O)3CO(BrFe3(ReCl)3(SO4)2)2)2MnO4" 31 | "2Tc 12H 6O 2C 2O 4Br 12Fe 12Re 12Cl 8S 32O Mn 4O" 32 | } 33 | { 34 | "(CH3)16(Tc(H2O)3CO(BrFe3(ReCl)3(SO4)2)2)2MnO4" 35 | "16C 48H 2Tc 12H 6O 2C 2O 4Br 12Fe 12Re 12Cl 8S 32O Mn 4O" 36 | } 37 | { "K4[Fe(SCN)6]" "4K Fe 6S 6C 6N" } 38 | } [ 39 | [ first symbol>string ] [ second ] bi = 40 | ] all? 41 | ] unit-test 42 | -------------------------------------------------------------------------------- /chemistry/chemistry.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: arrays fry kernel make math math.parser multiline 3 | peg.ebnf sequences strings ; 4 | 5 | IN: chemistry 6 | 7 | [[ sift >string ]] 12 | 13 | pair = [0-9]* { symbol | "("~ pair+ ")"~ } [0-9]* 14 | 15 | => [[ first3 swapd [ [ 1 ] [ string>number ] if-empty ] bi@ * 2array ]] 16 | 17 | bracket = "["~ pair "]"~ 18 | 19 | pairs = (bracket | pair)+ => [[ ]] 20 | 21 | ]=] 22 | 23 | : flatten-symbol, ( elt n -- ) 24 | [ first2 ] [ * ] bi* over string? 25 | [ 2array , ] [ '[ _ flatten-symbol, ] each ] if ; 26 | 27 | : flatten-symbol ( str -- seq ) 28 | parse-symbol [ [ 1 flatten-symbol, ] each ] { } make ; 29 | 30 | PRIVATE> 31 | 32 | : symbol>string ( str -- str' ) 33 | flatten-symbol [ 34 | first2 dup 1 = [ drop ] [ number>string prepend ] if 35 | ] map " " join ; 36 | -------------------------------------------------------------------------------- /cpu-speed/cpu-speed.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: cpu.x86.features kernel math tools.time ; 5 | 6 | IN: cpu-speed 7 | 8 | : busy-loop ( -- ) 9 | 100000000 [ 1 - dup 0 > ] loop drop ; 10 | 11 | : instructions-per-nano ( -- n ) 12 | [ [ busy-loop ] benchmark ] count-instructions swap / ; 13 | 14 | : cpu-speed ( -- n ) 15 | instructions-per-nano 1000000000.0 * ; 16 | -------------------------------------------------------------------------------- /cycles/cycles-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: cycles ranges tools.test ; 3 | 4 | { 5 | { 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1 } 6 | } [ 22 cycles ] unit-test 7 | 8 | { 1 } [ 1 cycle-length ] unit-test 9 | { 2 } [ 2 cycle-length ] unit-test 10 | { 6 } [ 5 cycle-length ] unit-test 11 | { 16 } [ 22 cycle-length ] unit-test 12 | 13 | { 20 } [ 1 10 [a..b] max-cycle-length ] unit-test 14 | { 125 } [ 100 200 [a..b] max-cycle-length ] unit-test 15 | { 89 } [ 201 210 [a..b] max-cycle-length ] unit-test 16 | { 174 } [ 900 1000 [a..b] max-cycle-length ] unit-test 17 | -------------------------------------------------------------------------------- /cycles/cycles.factor: -------------------------------------------------------------------------------- 1 | USING: assocs formatting io kernel math math.parser memoize 2 | ranges sequences sequences.extras splitting unicode ; 3 | 4 | IN: cycles 5 | 6 | : next-cycle ( x -- y ) 7 | dup odd? [ 3 * 1 + ] [ 2/ ] if ; inline 8 | 9 | : cycles ( n -- seq ) 10 | [ dup 1 > ] [ [ next-cycle ] keep ] produce swap suffix ; 11 | 12 | : cycle-length ( n -- m ) 13 | 1 [ over 1 > ] [ [ next-cycle ] [ 1 + ] bi* ] while nip ; 14 | 15 | : max-cycle ( seq -- elt ) 16 | [ dup cycle-length ] { } map>assoc [ second ] supremum-by ; 17 | 18 | : max-cycle-value ( seq -- n ) max-cycle first ; 19 | 20 | : max-cycle-length ( seq -- m ) max-cycle second ; 21 | 22 | MEMO: fast-cycle-length ( n -- m ) 23 | dup 1 > [ next-cycle fast-cycle-length 1 + ] [ drop 1 ] if ; 24 | 25 | : run-cycles ( -- ) 26 | [ 27 | [ blank? ] split-when harvest first2 28 | [ string>number ] bi@ 2dup [a..b] max-cycle-length 29 | "%s %s %s\n" printf 30 | ] each-line ; 31 | 32 | MAIN: run-cycles 33 | -------------------------------------------------------------------------------- /daytime/daytime.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: accessors calendar formatting kernel io 5 | io.encodings.ascii io.servers ; 6 | 7 | IN: daytime 8 | 9 | : ( port -- server ) 10 | ascii 11 | swap >>insecure 12 | "daytime.server" >>name 13 | [ now "%c" strftime print flush ] >>handler ; 14 | 15 | : daytimed ( port -- server ) 16 | start-server ; 17 | 18 | : daytimed-main ( -- ) 13 daytimed drop ; 19 | 20 | MAIN: daytimed-main 21 | 22 | -------------------------------------------------------------------------------- /derangements/derangements-tests.factor: -------------------------------------------------------------------------------- 1 | USING: derangements tools.test ; 2 | 3 | { 4 | { 5 | "BADC" 6 | "BCDA" 7 | "BDAC" 8 | "CADB" 9 | "CDAB" 10 | "CDBA" 11 | "DABC" 12 | "DCAB" 13 | "DCBA" 14 | } 15 | } [ "ABCD" all-derangements ] unit-test 16 | -------------------------------------------------------------------------------- /derangements/derangements.factor: -------------------------------------------------------------------------------- 1 | USING: arrays kernel math math.combinatorics 2 | math.combinatorics.private math.factorials random ranges 3 | sequences ; 4 | FROM: sequences.private => nth-unsafe exchange-unsafe ; 5 | 6 | IN: derangements 7 | 8 | : derangement? ( indices -- ? ) 9 | dup length [ = ] 2any? not ; 10 | 11 | : ( seq -- ) 12 | length subfactorial ; inline 13 | 14 | : next-derangement ( seq -- seq ) 15 | [ dup derangement? ] [ next-permutation ] do until ; 16 | 17 | : derangements-quot ( seq quot -- seq quot' ) 18 | [ [ ] [ length >array ] [ ] tri ] dip 19 | '[ drop _ next-derangement _ nths-unsafe @ ] ; inline 20 | 21 | : each-derangement ( ... seq quot: ( ... elt -- ... ) -- ... ) 22 | derangements-quot each ; inline 23 | 24 | : map-derangements ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq ) 25 | derangements-quot map ; inline 26 | 27 | : filter-derangements ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq ) 28 | selector [ each-derangement ] dip ; inline 29 | 30 | : all-derangements ( seq -- seq' ) 31 | [ ] map-derangements ; 32 | 33 | : all-derangements? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) 34 | derangements-quot all? ; inline 35 | 36 | : find-derangement ( ... seq quot: ( ... elt -- ... ? ) -- ... elt/f ) 37 | '[ _ keep and ] derangements-quot map-find drop ; inline 38 | 39 | : reduce-derangements ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result ) 40 | swapd each-derangement ; inline 41 | 42 | :: random-derangement-indices ( n -- indices ) 43 | n >array :> seq 44 | f [ 45 | dup :> v 46 | n 1 (a..b] [| j | 47 | j 1 + random :> p 48 | p v nth-unsafe j = 49 | [ t ] [ j p v exchange-unsafe f ] if 50 | ] any? v first zero? or 51 | ] [ drop seq clone ] do while ; 52 | 53 | : random-derangement ( seq -- seq' ) 54 | [ length random-derangement-indices ] [ nths-unsafe ] bi ; 55 | -------------------------------------------------------------------------------- /desktop-picture/desktop-picture.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors html.parser.analyzer http.client http.download 5 | io.files.temp kernel regexp sequences splitting strings system 6 | vocabs ; 7 | 8 | IN: desktop-picture 9 | 10 | HOOK: get-desktop-picture os ( -- path ) 11 | 12 | HOOK: set-desktop-picture os ( path -- ) 13 | 14 | : random-imgur ( -- url ) 15 | "https://imgur.com/random" scrape-html nip 16 | "image_src" "rel" find-by-attribute-key-value 17 | first "href" attribute ; 18 | 19 | : random-xkcd ( -- url ) 20 | "http://dynamic.xkcd.com/random/comic/" http-get nip 21 | R/ http:\/\/imgs\.xkcd\.com\/comics\/[^\.]+\.(png|jpg)/ 22 | first-match >string ; 23 | 24 | : random-wallpaperstock ( -- url ) 25 | "http://wallpaperstock.net/random-wallpapers.html" 26 | scrape-html nip "wallpaper_thumb" find-by-class-between 27 | "a" find-by-name nip "href" attribute 28 | "http://wallpaperstock.net" prepend scrape-html nip 29 | "the_view_link" find-by-id nip "href" attribute 30 | "http:" prepend scrape-html nip "myImage" find-by-id nip 31 | "src" attribute "http:" prepend ; 32 | 33 | : download-and-set-desktop-picture ( url -- ) 34 | dup "/" split1-last nip cache-file 35 | [ download-into ] [ set-desktop-picture ] bi ; 36 | 37 | "desktop-picture." os name>> append require 38 | -------------------------------------------------------------------------------- /desktop-picture/linux/linux.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: desktop-picture io io.encodings.utf8 io.launcher 5 | io.pathnames kernel sequences splitting system ; 6 | 7 | IN: desktop-picture.linux 8 | 9 | M: linux set-desktop-picture 10 | { 11 | "gsettings" 12 | "set" 13 | "org.gnome.desktop.background" 14 | "picture-uri" 15 | } swap absolute-path "file://" prepend suffix try-process ; 16 | 17 | M: linux get-desktop-picture 18 | { "gsettings" "get" "org.gnome.desktop.background" "picture-uri" } 19 | utf8 [ readln ] with-process-reader 20 | "'file://" ?head drop "'" ?tail drop ; 21 | -------------------------------------------------------------------------------- /desktop-picture/linux/platforms.txt: -------------------------------------------------------------------------------- 1 | linux 2 | -------------------------------------------------------------------------------- /desktop-picture/macos/macos.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: cocoa.apple-script desktop-picture formatting io 5 | io.encodings.utf8 io.launcher io.pathnames system ; 6 | 7 | IN: desktop-picture.macos 8 | 9 | M: macos set-desktop-picture 10 | absolute-path 11 | "tell application \"Finder\" to set desktop picture to POSIX file \"%s\"" 12 | sprintf run-apple-script ; 13 | 14 | M: macos get-desktop-picture 15 | { 16 | "osascript" "-e" 17 | "tell app \"Finder\" to get posix path of (get desktop picture as alias)" 18 | } utf8 [ readln ] with-process-reader ; 19 | -------------------------------------------------------------------------------- /desktop-picture/macos/platforms.txt: -------------------------------------------------------------------------------- 1 | macos 2 | -------------------------------------------------------------------------------- /desktop-picture/windows/platforms.txt: -------------------------------------------------------------------------------- 1 | windows 2 | -------------------------------------------------------------------------------- /desktop-picture/windows/windows.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: alien.data alien.strings desktop-picture 5 | io.encodings.string io.encodings.utf16n kernel math system 6 | windows.errors windows.kernel32 windows.types windows.user32 ; 7 | 8 | IN: desktop-picture.windows 9 | 10 | CONSTANT: SPI_SETDESKWALLPAPER 0x0014 11 | 12 | CONSTANT: SPI_GETDESKWALLPAPER 0x0073 13 | 14 | M: windows get-desktop-picture 15 | SPI_GETDESKWALLPAPER MAX_PATH dup 1 + WCHAR [ 16 | 0 SystemParametersInfo win32-error<>0 17 | ] keep alien>native-string ; 18 | 19 | M: windows set-desktop-picture 20 | [ SPI_SETDESKWALLPAPER 0 ] dip utf16n encode 21 | 0 SystemParametersInfo win32-error<>0 ; 22 | -------------------------------------------------------------------------------- /docs/dls-talk.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/docs/dls-talk.pdf -------------------------------------------------------------------------------- /docs/factor-articles.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/docs/factor-articles.pdf -------------------------------------------------------------------------------- /docs/periodic_genius.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/docs/periodic_genius.jpg -------------------------------------------------------------------------------- /domainr/domainr.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs classes.tuple formatting http.client 5 | json kernel namespaces sequences urls ; 6 | 7 | IN: domainr 8 | 9 | ! See: http://domainr.build/docs/authentication 10 | SYMBOL: mashape-key 11 | 12 | : domainr-url ( query -- url ) 13 | URL" https://api.domainr.com/v2/search" 14 | swap "query" set-query-param 15 | mashape-key get "mashape-key" set-query-param ; 16 | 17 | TUPLE: result domain host path subdomain availability 18 | register_url ; 19 | 20 | : domainr ( query -- data ) 21 | domainr-url http-get nip json> "results" of 22 | [ result from-slots ] map ; 23 | 24 | : domainr. ( query -- ) 25 | domainr [ 26 | [ subdomain>> ] [ path>> ] [ availability>> ] tri 27 | "%s%s - %s\n" printf 28 | ] each ; 29 | -------------------------------------------------------------------------------- /duckduckgo/duckduckgo.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: ascii assocs colors combinators html.parser 5 | html.parser.printer http.client images.http io 6 | io.encodings.string io.encodings.utf8 io.styles json kernel make 7 | sequences splitting urls wrap.strings ; 8 | 9 | IN: duckduckgo 10 | 11 | " split1 "" split1 31 | [ swap >url write-object nl ] 32 | [ parse-html html-text ] bi* 33 | [ blank? ] trim-head "- " ?head drop 34 | [ 78 wrap-string print ] unless-empty nl 35 | ] when* ; 36 | 37 | : abstract. ( results -- ) 38 | dup "Heading" of [ drop ] [ 39 | swap { 40 | [ "AbstractURL" of >url write-object nl ] 41 | [ "AbstractText" of 78 wrap-string print ] 42 | [ "AbstractSource" of "- " write print ] 43 | } cleave nl 44 | ] if-empty ; 45 | 46 | PRIVATE> 47 | 48 | : duckduckgo ( query -- results ) 49 | duckduckgo-url http-get nip utf8 decode json> ; 50 | 51 | : duckduckgo. ( query -- ) 52 | duckduckgo { 53 | [ "Image" of [ "https://duckduckgo.com" prepend http-image. ] unless-empty ] 54 | [ abstract. ] 55 | [ "Results" of [ result. ] each ] 56 | [ "RelatedTopics" of [ result. ] each ] 57 | } cleave ; 58 | -------------------------------------------------------------------------------- /dupe/dupe.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs checksums checksums.md5 command-line 5 | formatting fry hex-strings io.directories io.files.types 6 | io.pathnames kernel math math.parser namespaces sequences ; 7 | 8 | IN: dupe 9 | 10 | : collect-files ( path -- assoc ) 11 | t H{ } clone [ 12 | '[ 13 | dup type>> +regular-file+ = [ 14 | name>> dup file-name _ push-at 15 | ] [ drop ] if 16 | ] each-directory-entry 17 | ] keep ; 18 | 19 | : duplicate-files ( path -- dupes ) 20 | collect-files [ nip length 1 > ] assoc-filter! ; 21 | 22 | : md5-file ( path -- string ) 23 | md5 checksum-file bytes>hex-string ; 24 | 25 | : print-md5 ( name paths -- ) 26 | [ "%s:\n" printf ] [ 27 | [ dup md5-file " %s\n %s\n" printf ] each 28 | ] bi* ; 29 | 30 | : arg? ( name args -- args' ? ) 31 | 2dup member? [ remove t ] [ nip f ] if ; 32 | 33 | : parse-args ( -- verbose? root ) 34 | "--verbose" command-line get arg? swap first ; 35 | 36 | : run-dupe ( -- ) 37 | parse-args duplicate-files swap 38 | [ dup [ print-md5 ] assoc-each ] when 39 | assoc-size "Total duped files found: %d\n" printf ; 40 | 41 | MAIN: run-dupe 42 | -------------------------------------------------------------------------------- /dupe/dupe.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "crypto/md5" 5 | "flag" 6 | "fmt" 7 | "io/ioutil" 8 | "os" 9 | "path" 10 | "path/filepath" 11 | ) 12 | 13 | var verbose *bool = flag.Bool("verbose", false, "Print the list of duplicate files.") 14 | var rootDir string = "." 15 | var fullPathsByFilename map[string][]string 16 | 17 | func VisitFile(fullpath string, f os.FileInfo, err error) error { 18 | if err != nil { 19 | return err 20 | } 21 | if !f.IsDir() { 22 | filename := path.Base(fullpath) 23 | fullPathsByFilename[filename] = append(fullPathsByFilename[filename], fullpath) 24 | } 25 | return nil; 26 | } 27 | 28 | func MD5OfFile(fullpath string) []byte { 29 | if contents, err := ioutil.ReadFile(fullpath); err == nil { 30 | md5sum := md5.New() 31 | md5sum.Write(contents) 32 | return md5sum.Sum(nil) 33 | } 34 | return nil 35 | } 36 | 37 | func PrintResults() { 38 | dupes := 0 39 | for key, value := range fullPathsByFilename { 40 | if len(value) < 2 { 41 | continue 42 | } 43 | dupes++ 44 | if *verbose { 45 | println(key, ":") 46 | for _, filename := range value { 47 | println(" ", filename) 48 | fmt.Printf(" %x\n", MD5OfFile(filename)) 49 | } 50 | } 51 | } 52 | println("Total duped files found:", dupes) 53 | } 54 | 55 | func FindDupes(root string) { 56 | fullPathsByFilename = make(map[string][]string) 57 | filepath.Walk(root, VisitFile) 58 | } 59 | 60 | func ParseArgs() { 61 | flag.Parse() 62 | if len(flag.Args()) > 0 { 63 | rootDir = flag.Arg(0) 64 | } 65 | } 66 | 67 | func main() { 68 | ParseArgs() 69 | FindDupes(rootDir) 70 | PrintResults() 71 | } 72 | -------------------------------------------------------------------------------- /dupe/dupe.rb: -------------------------------------------------------------------------------- 1 | require 'find' 2 | require 'digest/md5' 3 | 4 | VERBOSE = ARGV.delete('--verbose') 5 | ROOT_DIR = ARGV[0] ||= "." 6 | 7 | @full_paths_by_filename = {} 8 | 9 | def md5_of_file(fullpath) 10 | Digest::MD5.hexdigest(File.read(fullpath)) 11 | end 12 | 13 | def visit_file(fullpath) 14 | return if File.directory? fullpath 15 | return if File.symlink? fullpath 16 | basename = File.basename(fullpath) 17 | (@full_paths_by_filename[basename] ||= []) << fullpath 18 | end 19 | 20 | def print_results 21 | @full_paths_by_filename.select! { |filename, fullpaths| fullpaths.length >= 2 } 22 | if (VERBOSE) 23 | @full_paths_by_filename.each do |filename, fullpaths| 24 | puts "#{filename}:" 25 | for path in fullpaths do 26 | puts " #{path}" 27 | puts " #{md5_of_file(path)}" 28 | end 29 | end 30 | end 31 | puts "Total duped files found: #{@full_paths_by_filename.length}" 32 | end 33 | 34 | Find.find(ROOT_DIR) do |fullpath| 35 | visit_file(fullpath) 36 | end 37 | 38 | print_results -------------------------------------------------------------------------------- /emoji/emoji.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: io io.files.info kernel math.order sequences sorting 3 | threads unicode ; 4 | 5 | IN: emoji 6 | 7 | ALIAS: 🆕 new 8 | 9 | ALIAS: 🔢 count 10 | 11 | ALIAS: 📶 sort 12 | 13 | ALIAS: 🔄 reverse 14 | 15 | ALIAS: 🔎 find 16 | 17 | ALIAS: 📁❓ directory? 18 | 19 | ALIAS: 🚽 flush 20 | 21 | ALIAS: 💤 sleep 22 | 23 | CONSTANT: 🔟 10 24 | 25 | CONSTANT: 💯 100 26 | 27 | ALIAS: 🆚 <=> 28 | 29 | ALIAS: 📞 call 30 | 31 | ALIAS: 🍛 curry 32 | 33 | ALIAS: 🔡 >lower 34 | 35 | ALIAS: 🔠 >upper 36 | 37 | ALIAS: 📏 length 38 | 39 | -------------------------------------------------------------------------------- /euler/euler.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel math random sequences ; 5 | 6 | IN: euler 7 | 8 | : random-float ( -- n ) 9 | 0.0 1.0 uniform-random ; 10 | 11 | : numbers-added ( -- n ) 12 | 0 0 [ dup 1 < ] [ 13 | [ 1 + ] dip random-float + 14 | ] while drop ; 15 | 16 | : average ( seq -- n ) 17 | [ sum ] [ length ] bi / ; 18 | 19 | : approximate-e ( n -- approx ) 20 | [ numbers-added ] replicate average ; 21 | 22 | ! Given that Pi can be estimated using the function 4 * (1 - 1/3 + 23 | ! 1/5 - 1/7 + ...) with more terms giving greater accuracy, write 24 | ! a function that calculates Pi to an accuracy of 5 decimal 25 | ! places. 26 | 27 | USE: ranges 28 | USE: math.vectors 29 | 30 | : approximate-pi ( n -- approx ) 31 | [1..b] 2 v*n 1 v-n 1 swap n/v 32 | [ odd? [ neg ] when ] map-index sum 4 * ; 33 | 34 | USE: locals 35 | 36 | : next-term ( approx i -- approx' ) 37 | [ 2 * 1 + ] [ odd? [ neg ] when ] bi 4.0 swap / + ; inline 38 | 39 | :: find-pi-to ( accuracy -- n approx ) 40 | 1 4.0 [ 41 | dup pick next-term [ - ] keep 42 | swap abs accuracy >= [ 1 + ] 2dip 43 | ] loop ; 44 | -------------------------------------------------------------------------------- /facebook/facebook.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs assocs.extras classes.tuple combinators 5 | http.client images.http json kernel sequences urls urls.encoding 6 | ; 7 | 8 | IN: facebook 9 | 10 | TUPLE: result application caption category created_time 11 | description end_time from icon id likes link location message message_tags 12 | name object_id picture privacy properties shares source start_time status_type 13 | story to type updated_time with_tags ; 14 | 15 | TUPLE: search results next-url prev-url ; 16 | 17 | { 21 | [ "data" of [ result from-slots ] map ] 22 | [ { "paging" "next" } deep-of ] 23 | [ { "paging" "previous" } deep-of ] 24 | } cleave \ search boa ; 25 | 26 | : search-url ( query type -- url ) 27 | URL" https://graph.facebook.com/search" 28 | swap "type" set-query-param 29 | swap "q" set-query-param ; 30 | 31 | : (search) ( query type -- search ) 32 | search-url http-search ; 33 | 34 | PRIVATE> 35 | 36 | : search ( str -- search ) f (search) ; 37 | 38 | : search-posts ( str -- search ) "post" (search) ; 39 | 40 | : search-users ( str -- search ) "user" (search) ; 41 | 42 | : search-pages ( str -- search ) "page" (search) ; 43 | 44 | : search-events ( str -- search ) "event" (search) ; 45 | 46 | : search-groups ( str -- search ) "group" (search) ; 47 | 48 | : next-page ( search -- search'/f ) 49 | next-url>> [ http-search ] [ f ] if* ; 50 | 51 | : prev-page ( search -- search'/f ) 52 | prev-url>> [ http-search ] [ f ] if* ; 53 | 54 | : picture. ( str -- ) 55 | url-encode 56 | "https://graph.facebook.com/" "/picture" surround 57 | http-image. ; 58 | 59 | : id-lookup ( id -- data ) 60 | "http://graph.facebook.com/" prepend http-get nip json> ; 61 | -------------------------------------------------------------------------------- /factors/factors.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: kernel math math.functions math.vectors ranges 5 | sequences sets ; 6 | 7 | IN: factors 8 | 9 | : factor? ( m n -- ? ) 10 | mod zero? ; 11 | 12 | : factors ( n -- seq ) 13 | dup [1..b] [ factor? ] with filter ; 14 | 15 | : factors' ( n -- seq ) 16 | dup sqrt ceiling >integer factors 17 | [ n/v ] keep append members ; 18 | 19 | : check-factors ( n quot: ( m n -- ? ) -- ? ) 20 | [ [ factors sum ] [ - ] ] dip tri ; inline 21 | 22 | : perfect? ( n -- ? ) [ = ] check-factors ; 23 | 24 | : abundant? ( n -- ? ) [ > ] check-factors ; 25 | 26 | : deficient? ( n -- ? ) [ < ] check-factors ; 27 | -------------------------------------------------------------------------------- /fake-data/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /fast-factorial/fast-factorial-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel math.factorials sequences tools.test ; 3 | 4 | IN: fast-factorial 5 | 6 | { t } [ 7 | 1,000 factorials [ fast-factorial = ] map-index [ ] all? 8 | ] unit-test 9 | -------------------------------------------------------------------------------- /fast-factorial/fast-factorial.factor: -------------------------------------------------------------------------------- 1 | USING: combinators kernel locals math math.bitwise ; 2 | 3 | IN: fast-factorial 4 | 5 | :: part-product ( n m -- x ) 6 | { 7 | { [ m n 1 + <= ] [ n ] } 8 | { [ m n 2 + = ] [ n m * ] } 9 | [ 10 | n m + 2 /i dup even? [ 1 - ] when :> k 11 | n k k 2 + m [ part-product ] 2bi@ * 12 | ] 13 | } cond ; 14 | 15 | :: factorial-loop ( n p r -- p' r' ) 16 | n 2 > [ 17 | n 2 /i :> mid 18 | mid p r factorial-loop 19 | [ 20 | mid 1 + mid 1 bitand + 21 | n 1 - n 1 bitand + part-product * 22 | ] [ dupd * ] bi* 23 | ] [ p r ] if ; 24 | 25 | : fast-factorial ( x -- n ) 26 | [ 1 1 factorial-loop nip ] [ dup bit-count - ] bi shift ; 27 | -------------------------------------------------------------------------------- /fast-fib/Makefile: -------------------------------------------------------------------------------- 1 | compile: 2 | gcc -I/opt/local/include -L/opt/local/lib -lgmp fib1.c -o fib1 3 | gcc -I/opt/local/include -L/opt/local/lib -lgmp fib2.c -o fib2 4 | gcc -I/opt/local/include -L/opt/local/lib -lgmp fib3.c -o fib3 5 | 6 | clean: 7 | rm fib1 fib2 fib3 8 | -------------------------------------------------------------------------------- /fast-fib/fast-fib-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: fast-fib sequences tools.test ; 3 | 4 | IN: fast-fib.tests 5 | 6 | [ -1 slow-fib ] must-fail 7 | [ { 0 1 1 2 3 5 8 } ] [ 7 [ slow-fib ] map ] unit-test 8 | 9 | [ -1 okay-fib ] must-fail 10 | [ { 0 1 1 2 3 5 8 } ] [ 7 [ okay-fib ] map ] unit-test 11 | 12 | [ -1 fast-fib ] must-fail 13 | [ { 0 1 1 2 3 5 8 } ] [ 7 [ fast-fib ] map ] unit-test 14 | -------------------------------------------------------------------------------- /fast-fib/fast-fib.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: combinators kernel locals math math.matrices 5 | math.matrices.extras math.parser memoize sequences ; 6 | 7 | IN: fast-fib 8 | 9 | MEMO: (slow-fib) ( m -- n ) 10 | dup 2 >= [ 11 | [ 2 - (slow-fib) ] [ 1 - (slow-fib) ] bi + 12 | ] when ; 13 | 14 | : slow-fib ( m -- n ) 15 | dup 0 >= [ throw ] unless (slow-fib) ; 16 | 17 | : okay-fib ( m -- n ) 18 | dup 0 >= [ throw ] unless 19 | [ 0 1 ] dip [ [ + ] [ drop ] 2bi ] times drop ; 20 | 21 | ! http://bosker.wordpress.com/2011/04/29/the-worst-algorithm-in-the-world/ 22 | ! http://gmplib.org/manual/Fibonacci-Numbers-Algorithm.html 23 | 24 | :: fast-fib ( m -- n ) 25 | m 0 >= [ m throw ] unless 26 | m 2 >base [ CHAR: 1 = ] { } map-as :> bits 27 | 1 0 1 bits [| a b c bit | 28 | bit [ 29 | a c + b * 30 | b sq c sq + 31 | ] [ 32 | a sq b sq + 33 | a c + b * 34 | ] if 2dup + 35 | ] each drop nip ; 36 | 37 | MEMO: (faster-fib) ( m -- n ) 38 | dup 1 > [ 39 | [ 2/ dup 1 - [ (faster-fib) ] bi@ ] [ 4 mod ] bi { 40 | { 1 [ [ 2 * ] dip [ + ] [ - ] 2bi * 2 + ] } 41 | { 3 [ [ 2 * ] dip [ + ] [ - ] 2bi * 2 - ] } 42 | [ drop dupd 2 * + * ] 43 | } case 44 | ] when ; 45 | 46 | : faster-fib ( m -- n ) 47 | dup 0 >= [ throw ] unless (faster-fib) ; 48 | 49 | MEMO: (slow-trib) ( m -- n ) 50 | dup 3 < [ 0 = 0 1 ? ] [ 51 | [ 3 - (slow-trib) ] 52 | [ 2 - (slow-trib) ] 53 | [ 1 - (slow-trib) ] tri + + 54 | ] if ; 55 | 56 | : slow-trib ( m -- n ) 57 | dup 0 >= [ throw ] unless (slow-trib) ; 58 | 59 | : okay-trib ( m -- n ) 60 | dup 0 >= [ throw ] unless 61 | [ 0 0 1 ] dip [ [ + + ] [ drop ] 3bi ] times 2drop ; 62 | 63 | : fast-trib ( m -- n ) 64 | { { 1 1 0 } { 1 0 1 } { 1 0 0 } } swap m^n first second ; 65 | -------------------------------------------------------------------------------- /fast-fib/fib1.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | int 6 | main(int argc, char **argv) { 7 | 8 | if(argc < 2) { 9 | fprintf(stderr, "Please enter a number of the Fibonacci series to compute.\n"); 10 | return 1; 11 | } 12 | 13 | mpz_t first, second, sum, count, stop; 14 | 15 | mpz_init(first); 16 | mpz_init(sum); 17 | 18 | mpz_init_set_ui(second, 1); 19 | mpz_init_set_ui(count, 1); 20 | mpz_init_set_str(stop, argv[1], 10); 21 | 22 | while(mpz_cmp(stop, count)) { 23 | mpz_add(sum, first, second); 24 | mpz_set(first, second); 25 | mpz_set(second, sum); 26 | mpz_add_ui(count, count, 1); 27 | } 28 | 29 | mpz_out_str(stdout, 10, sum); 30 | printf("\n"); 31 | 32 | return 0; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /fast-fib/fib2.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | int 6 | main(int argc, char **argv) { 7 | 8 | if(argc < 2) { 9 | fprintf(stderr, "Please enter a number of the Fibonacci series to compute.\n"); 10 | return 1; 11 | } 12 | 13 | mpz_t sum; 14 | 15 | mpz_init(sum); 16 | mpz_fib_ui(sum, atoi(argv[1])); 17 | mpz_out_str(stdout, 10, sum); 18 | printf("\n"); 19 | 20 | return 0; 21 | } 22 | 23 | -------------------------------------------------------------------------------- /fast-fib/fib3.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | int 7 | main(int argc, char **argv) { 8 | 9 | if(argc < 2) { 10 | fprintf(stderr, "Please enter a number of the Fibonacci series to compute.\n"); 11 | return 1; 12 | } 13 | 14 | uint32_t v = atoi(argv[1]); 15 | 16 | mpz_t a, b, c, tmp1, tmp2, new_a, new_b; 17 | 18 | mpz_init(a); 19 | mpz_init(b); 20 | mpz_init(c); 21 | mpz_init(tmp1); 22 | mpz_init(tmp2); 23 | mpz_init(new_a); 24 | mpz_init(new_b); 25 | 26 | mpz_init_set_ui(a, 1); 27 | mpz_init_set_ui(b, 0); 28 | mpz_init_set_ui(c, 1); 29 | 30 | int bits = 31; 31 | while (bits > 0 && !((v >> bits) & 1)) { 32 | bits--; 33 | } 34 | while (bits >= 0) { 35 | 36 | if((v >> bits) & 1) { 37 | mpz_add(tmp1, a, c); 38 | mpz_mul(new_a, tmp1, b); 39 | 40 | mpz_mul(tmp1, b, b); 41 | mpz_mul(tmp2, c, c); 42 | mpz_add(new_b, tmp1, tmp2); 43 | } else { 44 | mpz_mul(tmp1, a, a); 45 | mpz_mul(tmp2, b, b); 46 | mpz_add(new_a, tmp1, tmp2); 47 | 48 | mpz_add(tmp1, a, c); 49 | mpz_mul(new_b, tmp1, b); 50 | } 51 | 52 | mpz_set(a, new_a); 53 | mpz_set(b, new_b); 54 | mpz_add(c, a, b); 55 | bits--; 56 | } 57 | 58 | mpz_out_str(stdout, 10, b); 59 | printf("\n"); 60 | 61 | return 0; 62 | } 63 | 64 | -------------------------------------------------------------------------------- /fast-now/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /fast-now/fast-now-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: calendar fast-now kernel math tools.test tools.time ; 5 | 6 | IN: fast-now.tests 7 | 8 | [ f ] [ now now = ] unit-test 9 | 10 | [ t ] [ fast-now fast-now eq? ] unit-test 11 | 12 | [ t ] [ 13 | [ fast-now [ dup fast-now eq? ] loop drop ] benchmark 14 | 1075000 < 15 | ] unit-test 16 | 17 | -------------------------------------------------------------------------------- /fast-now/fast-now.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: calendar kernel math namespaces system ; 5 | 6 | IN: fast-now 7 | 8 | ; 17 | 18 | : reset-cache ( nanos -- ) 19 | cache-duration + cache-until set-global ; 20 | 21 | : update-cache ( nanos -- timestamp ) 22 | reset-cache now [ cache-value set-global ] keep ; 23 | 24 | PRIVATE> 25 | 26 | : fast-now ( -- timestamp ) 27 | nano-count dup cache-expired? [ update-cache ] [ 28 | drop cache-value get-global 29 | ] if ; 30 | -------------------------------------------------------------------------------- /fast-now/summary.txt: -------------------------------------------------------------------------------- 1 | Faster, cached-per-millisecond version of "now" 2 | -------------------------------------------------------------------------------- /fast-pow/fast-pow-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: fast-pow kernel math math.functions memory random 3 | sequences tools.test tools.time ; 4 | 5 | IN: fast-pow.tests 6 | 7 | [ 0.5 ] [ -1 pow2 ] unit-test 8 | [ 1.0 ] [ 0 pow2 ] unit-test 9 | [ 2.0 ] [ 1 pow2 ] unit-test 10 | [ 4.0 ] [ 2 pow2 ] unit-test 11 | [ 1024.0 ] [ 10 pow2 ] unit-test 12 | [ 0.0009765625 ] [ -10 pow2 ] unit-test 13 | [ 0.81225239593676 ] [ -0.3 pow2 ] unit-test 14 | [ 3.24900958374704 ] [ 1.7 pow2 ] unit-test 15 | 16 | : pow2-seq ( n -- seq ) 17 | [ -20 20 uniform-random-float ] replicate ; 18 | 19 | : pow2-test ( seq -- new old ) 20 | [ [ pow2 drop ] [ each ] benchmark ] 21 | [ 2 swap [ ^ drop ] with [ each ] benchmark ] bi ; 22 | 23 | ! check its at least 25% faster 24 | [ t ] [ 10000 pow2-seq gc pow2-test / 0.75 < ] unit-test 25 | 26 | : relative-error ( approx value -- relative-error ) 27 | [ - abs ] keep / ; 28 | 29 | [ t ] [ 30 | 10000 pow2-seq 31 | [ [ pow2 ] [ 2 swap ^ ] bi relative-error ] map 32 | supremum 1e-9 < 33 | ] unit-test 34 | 35 | ! "orig" print [ 1000000 [ 2 16.3 ^ drop ] times ] time 36 | ! "pow2" print [ 1000000 [ 16.3 pow2 drop ] times ] time 37 | 38 | -------------------------------------------------------------------------------- /fast-pow/fast-pow.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel literals math math.functions sequences 5 | sequences.private ; 6 | 7 | IN: fast-pow 8 | 9 | ! fast-pow: 10 | ! http://martin.ankerl.com/2007/10/04/optimized-pow-approximation-for-java-and-c-c/ 11 | 12 | : fast-log ( x -- y ) 13 | double>bits -32 shift 1072632447 - 1512775 / ; 14 | 15 | : fast-exp ( x -- e^x ) 16 | 1512775 * 1072693248 60801 - + 32 shift bits>double ; 17 | 18 | : fast-pow ( a b -- a^b ) 19 | [ double>bits -32 shift 1072632447 - ] 20 | [ * 1072632447 + >integer 32 shift bits>double ] bi* ; 21 | 22 | ! fast-pow2: 23 | ! http://falasol.net/2-pow-x-optimization-for-double-type 24 | 25 | : float>parts ( x -- float int ) 26 | dup >integer [ - ] keep ; inline 27 | 28 | << 29 | CONSTANT: BITS1 10 30 | >> 31 | 32 | << 33 | CONSTANT: BITS2 $[ BITS1 2 * ] 34 | CONSTANT: BITS3 $[ BITS1 3 * ] 35 | >> 36 | 37 | << 38 | CONSTANT: PRECISION1 $[ 1 BITS1 shift ] 39 | CONSTANT: PRECISION2 $[ 1 BITS2 shift ] 40 | CONSTANT: PRECISION3 $[ 1 BITS3 shift ] 41 | >> 42 | 43 | << 44 | CONSTANT: MASK $[ PRECISION1 1 - ] 45 | 46 | CONSTANT: FRAC1 $[ 2 PRECISION1 [ PRECISION1 / ^ ] with map ] 47 | CONSTANT: FRAC2 $[ 2 PRECISION1 [ PRECISION2 / ^ ] with map ] 48 | CONSTANT: FRAC3 $[ 2 PRECISION1 [ PRECISION3 / ^ ] with map ] 49 | >> 50 | 51 | ! a ^ ( b + c ) == a ^ b * a ^ c 52 | ! a = 2 53 | ! b = int(a) // integer part 54 | ! c = frac(a) // fractional part 55 | 56 | : 2^int ( n -- 2^int frac ) 57 | [ float>parts ] keep 0 >= [ 1 swap shift ] [ 58 | over 0 < [ [ 1 + ] [ 1 - ] bi* ] when 59 | 1 swap neg shift 1.0 swap / 60 | ] if swap ; inline 61 | 62 | : 2^frac ( frac -- 2^frac ) 63 | PRECISION3 * >fixnum 64 | [ BITS2 neg shift FRAC1 nth-unsafe ] 65 | [ BITS1 neg shift MASK bitand FRAC2 nth-unsafe ] 66 | [ MASK bitand FRAC3 nth-unsafe ] tri * * ; inline 67 | 68 | : pow2 ( n -- 2^n ) 69 | >float 2^int 2^frac * >float ; 70 | 71 | 72 | ! Other sources: 73 | ! http://www.hxa.name/articles/content/fast-pow-adjustable_hxa7241_2007.html 74 | ! http://jrfonseca.blogspot.com/2008/09/fast-sse2-pow-tables-or-polynomials.html 75 | 76 | -------------------------------------------------------------------------------- /fizzbuzz/fizzbuzz-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: assocs fizzbuzz kernel io.streams.string ranges 3 | sequences sets tools.test ; 4 | 5 | IN: fizzbuzz 6 | 7 | [ t ] [ 8 | 100 [1..b] { 9 | [ fizzbuzz1 ] 10 | [ fizzbuzz2 ] 11 | [ fizzbuzz3 ] 12 | } [ [ each ] curry with-string-writer ] with map 13 | unique assoc-size 1 = 14 | ] unit-test 15 | -------------------------------------------------------------------------------- /fizzbuzz/fizzbuzz.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: arrays assocs combinators combinators.extras io kernel 5 | math.functions present sequences utils ; 6 | 7 | IN: fizzbuzz 8 | 9 | : fizzbuzz1 ( n -- ) 10 | { 11 | { [ dup 15 divisor? ] [ drop "FizzBuzz" ] } 12 | { [ dup 3 divisor? ] [ drop "Fizz" ] } 13 | { [ dup 5 divisor? ] [ drop "Buzz" ] } 14 | [ present ] 15 | } cond print ; 16 | 17 | : fizzbuzz2 ( n -- ) 18 | { 19 | { [ 15 divisor? ] [ "FizzBuzz" ] } 20 | { [ 3 divisor? ] [ "Fizz" ] } 21 | { [ 5 divisor? ] [ "Buzz" ] } 22 | [ present ] 23 | } cond-case print ; 24 | 25 | : fizz ( n -- str/f ) 26 | 3 divisor? "Fizz" and ; 27 | 28 | : buzz ( n -- str/f ) 29 | 5 divisor? "Buzz" and ; 30 | 31 | : fizzbuzz3 ( n -- ) 32 | dup [ fizz ] [ buzz ] bi "" append-as 33 | [ present ] [ nip ] if-empty print ; 34 | 35 | 36 | : fizzbuzz? ( n -- test ) 37 | [ 3 divisor? ] [ 5 divisor? ] bi 2array ; 38 | 39 | : fizzbuzz4 ( n -- ) 40 | dup fizzbuzz? H{ 41 | { t t } => "FizzBuzz" 42 | { t f } => "Fizz" 43 | { f t } => "Buzz" 44 | } at [ nip ] [ present ] if* print ; 45 | -------------------------------------------------------------------------------- /fortune/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-name "fortune" } 4 | { deploy-ui? f } 5 | { deploy-c-types? f } 6 | { deploy-console? t } 7 | { deploy-unicode? f } 8 | { "stop-after-last-window?" t } 9 | { deploy-io 3 } 10 | { deploy-reflection 6 } 11 | { deploy-word-props? f } 12 | { deploy-math? t } 13 | { deploy-threads? t } 14 | { deploy-word-defs? f } 15 | } 16 | -------------------------------------------------------------------------------- /fortune/fortune.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: io io.encodings.ascii io.files kernel make memoize 5 | random sequences splitting strings ; 6 | 7 | IN: fortune 8 | 9 | CONSTANT: FORTUNES { 10 | "/usr/games/fortune/fortunes" 11 | "/usr/share/fortune/fortunes" 12 | "/usr/share/games/fortune/fortunes" 13 | "/usr/share/games/fortunes/fortunes" 14 | "/usr/local/share/games/fortune/fortunes" 15 | "/opt/local/share/games/fortune/fortunes" 16 | } 17 | 18 | : parse-fortune ( str -- seq ) 19 | [ 20 | [ "%\n" split1-slice dup ] 21 | [ swap , ] while drop , 22 | ] { } make ; 23 | 24 | : load-fortunes ( path -- seq ) 25 | ascii file-contents parse-fortune ; 26 | 27 | MEMO: default-fortunes ( -- seq ) 28 | FORTUNES [ file-exists? ] find nip load-fortunes ; 29 | 30 | : fortune ( -- ) 31 | default-fortunes random >string print ; 32 | 33 | MAIN: fortune 34 | 35 | -------------------------------------------------------------------------------- /fortune/summary.txt: -------------------------------------------------------------------------------- 1 | Fortune program to print random quotations. 2 | -------------------------------------------------------------------------------- /friday-13th/friday-13th-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors assocs calendar friday-13th math.statistics 3 | sequences tools.test ; 4 | 5 | IN: friday-13th 6 | 7 | [ f ] [ 2012 1 01 friday-13th? ] unit-test 8 | [ t ] [ 2012 1 13 friday-13th? ] unit-test 9 | [ f ] [ 2012 2 13 friday-13th? ] unit-test 10 | 11 | [ 3 ] [ 2012 friday-13ths length ] unit-test 12 | 13 | [ 3 ] [ 14 | 500 2012 all-friday-13ths 15 | [ year>> ] collect-by >alist 16 | [ second length ] histogram-by 17 | assoc-size 18 | ] unit-test 19 | -------------------------------------------------------------------------------- /friday-13th/friday-13th.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors calendar kernel math ranges sequences ; 3 | 4 | IN: friday-13th 5 | 6 | : friday-13th? ( timestamp -- ? ) 7 | [ day>> 13 = ] [ friday? ] bi and ; 8 | 9 | : friday-13ths ( year -- seq ) 10 | 12 [0..b) [ 11 | 13 dup friday? [ drop f ] unless 12 | ] with map sift ; 13 | 14 | : all-friday-13ths ( start-year end-year -- seq ) 15 | [a..b] [ friday-13ths ] map concat ; 16 | 17 | : next-friday-13th ( timestamp -- date ) 18 | dup day>> 13 >= [ 1 months time+ ] when 13 >>day 19 | [ dup friday? not ] [ 1 months time+ ] while ; 20 | -------------------------------------------------------------------------------- /gaddafi/gaddafi-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: gaddafi regexp sequences tools.test ; 5 | 6 | [ t ] [ names [ gaddafi? ] all? ] unit-test 7 | [ t ] [ names [ re1-gaddafi? ] all? ] unit-test 8 | [ t ] [ names [ re2-gaddafi? ] all? ] unit-test 9 | [ t ] [ names [ soundex-gaddafi? ] all? ] unit-test 10 | -------------------------------------------------------------------------------- /geekcode/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /geekcode/geekcode.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors arrays assocs combinators.short-circuit 5 | grouping hashtables html.parser html.parser.analyzer 6 | html.parser.printer http.client io io.styles kernel memoize 7 | sequences splitting unicode wrap.strings ; 8 | 9 | FROM: sequences => change-nth ; 10 | 11 | IN: geekcode 12 | 13 | > "dt" = ] split-when [ 20 | [ name>> "dd" = ] split-when 21 | [ html-text split-text " " join ] map harvest 22 | ] map harvest ; 23 | 24 | : parse-section-attrs ( seq -- specs ) 25 | [ name>> "dl" = ] find-between-all 2 tail 2 head* 26 | [ parse-section-attr ] map 0 over [ 27 | first [ " " split1 " " split1 nip 2array ] map 28 | ] change-nth [ >hashtable ] map ; 29 | 30 | : parse-section-names ( seq -- names ) 31 | [ 32 | { [ name>> "hr" = ] [ "size" attribute not ] } 1&& 33 | ] split-when 4 tail [ 34 | "h2" find-between-first first text>> 35 | ] map "Type" prefix ; 36 | 37 | : parse-spec ( seq -- spec ) 38 | [ parse-section-names ] [ parse-section-attrs ] bi zip ; 39 | 40 | MEMO: geekcode-spec ( -- obj ) 41 | "http://www.geekcode.com/geek.html" http-get nip 42 | parse-html parse-spec ; 43 | 44 | : lookup-code ( code -- result/f ) 45 | geekcode-spec [ second at ] with map-find 46 | [ first swap 2array ] [ drop f ] if* ; 47 | 48 | PRIVATE> 49 | 50 | : geekcode ( geekcode -- str ) 51 | split-text [ lookup-code ] map harvest ; 52 | 53 | : geekcode. ( geekcode -- ) 54 | geekcode standard-table-style [ 55 | [ 56 | [ 57 | [ [ write ] with-cell ] 58 | [ [ 60 wrap-string write ] with-cell ] bi* 59 | ] with-row 60 | ] assoc-each 61 | ] tabular-output nl ; 62 | -------------------------------------------------------------------------------- /geekcode/summary.txt: -------------------------------------------------------------------------------- 1 | The Code of the Geeks 2 | -------------------------------------------------------------------------------- /geo-tz/geo-tz-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | IN: geo-tz 3 | 4 | { "America/Los_Angeles" } [ 37.7833 -122.4167 lookup-zone ] unit-test 5 | { "Australia/Sydney" } [ -33.8885 151.1908 lookup-zone ] unit-test 6 | { f } [ 0 0 lookup-zone ] unit-test 7 | 8 | { "Asia/Phnom_Penh" } [ 9200 2410 lookup-pixel ] unit-test 9 | { "Asia/Phnom_Penh" } [ 9047 2488 lookup-pixel ] unit-test 10 | 11 | ! one-bit leaf tile 12 | { "Asia/Krasnoyarsk" } [ 9290 530 lookup-pixel ] unit-test 13 | { "Asia/Yakutsk" } [ 9290 531 lookup-pixel ] unit-test 14 | 15 | ! four-bit tile 16 | { "America/Indiana/Vincennes" } [ 2985 1654 lookup-pixel ] unit-test 17 | { "America/Indiana/Marengo" } [ 2986 1654 lookup-pixel ] unit-test 18 | { "America/Indiana/Tell_City" } [ 2986 1655 lookup-pixel ] unit-test 19 | 20 | ! Empty tile 21 | { f } [ 4000 2000 lookup-pixel ] unit-test 22 | 23 | ! Big 1-color tile in ocean with island 24 | { "Atlantic/Bermuda" } [ 3687 1845 lookup-pixel ] unit-test 25 | ! Same, but off Oregon coast 26 | { "America/Los_Angeles" } [ 1747 1486 lookup-pixel ] unit-test 27 | 28 | ! Little solid tile 29 | { "America/Belize" } [ 2924 2316 lookup-pixel ] unit-test 30 | -------------------------------------------------------------------------------- /geo-tz/geo-tz.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors alien.c-types alien.data alien.endian 5 | binary-search byte-arrays classes.struct combinators 6 | command-line io io.encodings.binary io.encodings.string 7 | io.encodings.utf8 io.files kernel literals math math.bitwise 8 | math.order math.parser namespaces sequences specialized-arrays 9 | strings ; 10 | 11 | IN: geo-tz 12 | 13 | CONSTANT: deg-pixels 32 14 | 15 | << 16 | BE-PACKED-STRUCT: tile 17 | { key uint } 18 | { idx ushort } ; 19 | >> 20 | 21 | SPECIALIZED-ARRAY: tile 22 | 23 | CONSTANT: zoom-levels $[ 24 | 6 [ 25 | number>string 26 | "vocab:geo-tz/zoom" ".dat" surround 27 | binary file-contents tile cast-array 28 | ] map 29 | ] 30 | 31 | << 32 | CONSTANT: #leaves 14110 33 | 34 | BE-PACKED-STRUCT: one-bit-tile 35 | { idx0 ushort } 36 | { idx1 ushort } 37 | { bits ulonglong } ; 38 | >> 39 | 40 | CONSTANT: unique-leaves $[ 41 | "vocab:geo-tz/leaves.dat" binary [ 42 | #leaves [ 43 | read1 { 44 | { CHAR: S [ { 0 } read-until drop utf8 decode ] } 45 | { CHAR: 2 [ one-bit-tile read-struct ] } 46 | { CHAR: P [ 128 read ] } 47 | } case 48 | ] replicate 49 | ] with-file-reader 50 | ] 51 | 52 | CONSTANT: ocean-index 0xffff 53 | 54 | GENERIC#: lookup-leaf 2 ( leaf x y -- zone/f ) 55 | 56 | M: string lookup-leaf 2drop ; 57 | 58 | M:: one-bit-tile lookup-leaf ( leaf x y -- zone/f ) 59 | leaf bits>> y 3 bits 3 shift x 3 bits bitor bit? 60 | [ leaf idx1>> ] [ leaf idx0>> ] if 61 | unique-leaves nth x y lookup-leaf ; 62 | 63 | M:: byte-array lookup-leaf ( leaf x y -- zone/f ) 64 | y 3 bits 3 shift x 3 bits bitor 2 * :> i 65 | i leaf nth 8 shift i 1 + leaf nth + 66 | dup ocean-index = [ drop f ] [ 67 | unique-leaves nth x y lookup-leaf 68 | ] if ; 69 | 70 | :: lookup-zoom-level ( zoom-level x y tile-key -- zone/f ) 71 | zoom-level [ key>> tile-key >=< ] search swap [ 72 | dup key>> tile-key = [ 73 | idx>> unique-leaves nth x y lookup-leaf 74 | ] [ drop f ] if 75 | ] [ drop f ] if ; 76 | 77 | :: tile-key ( x y level -- tile-key ) 78 | level dup 3 + neg :> n 79 | y x [ n shift 14 bits ] bi@ 80 | { 0 14 28 } bitfield ; 81 | 82 | :: lookup-pixel ( x y -- zone ) 83 | 6 [| level | 84 | level zoom-levels nth 85 | x y 2dup level tile-key 86 | lookup-zoom-level 87 | ] map-find-last drop ; 88 | 89 | :: lookup-zone ( lat lon -- zone ) 90 | lon 180 + deg-pixels * 0 360 deg-pixels * 1 - clamp 91 | 90 lat - deg-pixels * 0 180 deg-pixels * 1 - clamp 92 | [ >integer ] bi@ lookup-pixel ; 93 | 94 | : geo-tz-main ( -- ) 95 | command-line get dup length 2 < [ 96 | drop "Usage: geo-tz latitude longitude" print 97 | ] [ 98 | first2 [ string>number ] bi@ lookup-zone print 99 | ] if ; 100 | 101 | MAIN: geo-tz-main 102 | -------------------------------------------------------------------------------- /geo-tz/leaves.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/leaves.dat -------------------------------------------------------------------------------- /geo-tz/zoom0.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom0.dat -------------------------------------------------------------------------------- /geo-tz/zoom1.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom1.dat -------------------------------------------------------------------------------- /geo-tz/zoom2.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom2.dat -------------------------------------------------------------------------------- /geo-tz/zoom3.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom3.dat -------------------------------------------------------------------------------- /geo-tz/zoom4.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom4.dat -------------------------------------------------------------------------------- /geo-tz/zoom5.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/geo-tz/zoom5.dat -------------------------------------------------------------------------------- /github/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /github/github.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs classes.tuple combinators formatting 5 | http.client json kernel math sequences sorting ; 6 | 7 | IN: github 8 | 9 | CONSTANT: API-URL "https://github.com/api/v2/json" 10 | 11 | ] [ of ] bi* ; 27 | 28 | PRIVATE> 29 | 30 | : user-info ( login -- user ) 31 | "/user/show/%s" sprintf "user" json-data 32 | \ user from-slots ; 33 | 34 | : following ( login -- seq ) 35 | "/user/show/%s/following" sprintf "users" json-data ; 36 | 37 | : followers ( login -- seq ) 38 | "/user/show/%s/followers" sprintf "users" json-data ; 39 | 40 | : repositories ( login -- seq ) 41 | "/repos/show/%s" sprintf "repositories" json-data 42 | [ \ repository from-slots ] map ; 43 | 44 | : watched ( login -- seq ) 45 | "/repos/watched/%s" sprintf "repositories" json-data 46 | [ \ repository from-slots ] map ; 47 | 48 | : repository ( login reponame -- repo ) 49 | "/repos/show/%s/%s" sprintf "repository" json-data 50 | \ repository from-slots ; 51 | 52 | : branches ( login reponame -- seq ) 53 | "/repos/show/%s/%s/branches" sprintf "branches" json-data ; 54 | 55 | : network ( login reponame -- seq ) 56 | "/repos/show/%s/%s/network" sprintf "network" json-data 57 | [ \ repository from-slots ] map ; 58 | 59 | : commits ( login reponame branch -- seq ) 60 | "/commits/list/%s/%s/%s" sprintf "commits" json-data 61 | [ \ commit from-slots ] map ; 62 | 63 | : commit ( login reponame commit-id -- commit ) 64 | "/commits/show/%s/%s/%s" sprintf "commit" json-data 65 | \ commit from-slots ; 66 | 67 | : vain ( login -- ) 68 | [ 69 | user-info { 70 | [ login>> ] 71 | [ followers_count>> ] 72 | [ public_repo_count>> ] 73 | } cleave 74 | "%s - %s followers - %s public repositories\n" printf 75 | ] [ 76 | repositories [ watchers>> ] inv-sort-with [ 77 | { 78 | [ name>> ] 79 | [ watchers>> "%s watchers" sprintf ] 80 | [ forks>> "%s forks" sprintf ] 81 | [ fork>> "(FORK)" "" ? ] 82 | } cleave "%-25s %13s %12s %s\n" printf 83 | ] each 84 | ] bi ; 85 | -------------------------------------------------------------------------------- /github/summary.txt: -------------------------------------------------------------------------------- 1 | Github API 2 | -------------------------------------------------------------------------------- /godel/godel-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | 3 | IN: godel 4 | 5 | { "PRAXIS" } [ 6 | 83838469305478699942290773046821079668485703984645720358854000640 7 | gödel> 8 | ] unit-test 9 | 10 | { 11 | 83838469305478699942290773046821079668485703984645720358854000640 12 | } [ "PRAXIS" >gödel ] unit-test 13 | -------------------------------------------------------------------------------- /godel/godel.factor: -------------------------------------------------------------------------------- 1 | USING: ascii assocs kernel math math.functions math.primes 2 | math.primes.factors sequences ; 3 | 4 | IN: godel 5 | 6 | : >gödel ( str -- n ) 7 | [ length nprimes ] keep [ 64 - ^ ] 2map product ; 8 | 9 | : gödel> ( n -- str ) 10 | group-factors values [ 64 + ] "" map-as ; 11 | -------------------------------------------------------------------------------- /google/buzz/buzz.factor: -------------------------------------------------------------------------------- 1 | 2 | USE: assocs 3 | USE: formatting 4 | USE: google 5 | USE: http.client 6 | USE: json 7 | USE: kernel 8 | USE: locals 9 | USE: math.parser 10 | USE: namespaces 11 | USE: sequences 12 | USE: urls 13 | USE: xml 14 | USE: xml.traversal 15 | 16 | IN: google.buzz 17 | 18 | url 22 | google-api-key get-global "key" set-query-param ; 23 | 24 | : buzz-get ( url -- data ) 25 | http-get nip json> "data" of ; 26 | 27 | PRIVATE> 28 | 29 | :: activities/count ( language url -- n ) 30 | "/activities/count" buzz-url 31 | language "hl" set-query-param 32 | url "url" set-query-param 33 | http-get nip string>xml "total" deep-tag-named 34 | children>string string>number ; 35 | 36 | : activities/list ( user-id scope -- xml ) 37 | "/activities/%s/%s" sprintf buzz-url 38 | http-get nip string>xml ; 39 | 40 | : activities/search ( query -- results ) 41 | "/activities/search" buzz-url 42 | swap "q" set-query-param 43 | "json" "alt" set-query-param 44 | buzz-get "items" of ; 45 | 46 | : activities/search-people ( query -- results ) 47 | "/activities/search/@people" buzz-url 48 | swap "q" set-query-param 49 | "json" "alt" set-query-param 50 | buzz-get "entry" of ; 51 | 52 | : people/get ( user-id -- xml ) 53 | "/people/%s/@self" sprintf buzz-url 54 | http-get nip string>xml ; 55 | 56 | : people/search ( query -- results ) 57 | "/people/search" buzz-url 58 | swap "q" set-query-param 59 | "json" "alt" set-query-param 60 | buzz-get "entry" of ; 61 | 62 | 63 | -------------------------------------------------------------------------------- /google/google.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: namespaces ; 5 | 6 | IN: google 7 | 8 | SYMBOL: google-api-key 9 | -------------------------------------------------------------------------------- /google/translate/summary.txt: -------------------------------------------------------------------------------- 1 | Google Translate API 2 | -------------------------------------------------------------------------------- /google/translate/translate.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: assocs assocs.extras google http.client io json kernel 5 | locals namespaces sequences urls utils ; 6 | 7 | IN: google.translate 8 | 9 | CONSTANT: languages H{ 10 | { "Afrikaans" "af" } 11 | { "Albanian" "sq" } 12 | { "Arabic" "ar" } 13 | { "Belarusian" "be" } 14 | { "Bulgarian" "bg" } 15 | { "Catalan" "ca" } 16 | { "Chinese Simplified" "zh-CN" } 17 | { "Chinese Traditional" "zh-TW" } 18 | { "Croatian" "hr" } 19 | { "Czech" "cs" } 20 | { "Danish" "da" } 21 | { "Dutch" "nl" } 22 | { "English" "en" } 23 | { "Estonian" "et" } 24 | { "Filipino" "tl" } 25 | { "Finnish" "fi" } 26 | { "French" "fr" } 27 | { "Galician" "gl" } 28 | { "German" "de" } 29 | { "Greek" "el" } 30 | { "Haitian Creole" "ht" } 31 | { "Hebrew" "iw" } 32 | { "Hindi" "hi" } 33 | { "Hungarian" "hu" } 34 | { "Icelandic" "is" } 35 | { "Indonesian" "id" } 36 | { "Irish" "ga" } 37 | { "Italian" "it" } 38 | { "Japanese" "ja" } 39 | { "Latvian" "lv" } 40 | { "Lithuanian" "lt" } 41 | { "Macedonian" "mk" } 42 | { "Malay" "ms" } 43 | { "Maltese" "mt" } 44 | { "Norwegian" "no" } 45 | { "Persian" "fa" } 46 | { "Polish" "pl" } 47 | { "Portuguese" "pt" } 48 | { "Romanian" "ro" } 49 | { "Russian" "ru" } 50 | { "Serbian" "sr" } 51 | { "Slovak" "sk" } 52 | { "Slovenian" "sl" } 53 | { "Spanish" "es" } 54 | { "Swahili" "sw" } 55 | { "Swedish" "sv" } 56 | { "Thai" "th" } 57 | { "Turkish" "tr" } 58 | { "Ukrainian" "uk" } 59 | { "Vietnamese" "vi" } 60 | { "Welsh" "cy" } 61 | { "Yiddish" "yi" } 62 | } 63 | 64 | :: translate-url ( text source target -- url ) 65 | URL" https://www.googleapis.com/language/translate/v2" 66 | google-api-key get-global "key" set-query-param 67 | source "source" set-query-param 68 | target "target" set-query-param 69 | text "q" set-query-param ; 70 | 71 | : translate ( text source target -- text' ) 72 | translate-url http-get nip json> 73 | { "data" "translations" } deep-of 74 | first "translatedText" of ; 75 | 76 | :: all-translations ( text source -- assoc ) 77 | languages [ 78 | dup source = [ drop text ] [ 79 | [ text source ] dip translate 80 | ] if 81 | ] assoc-map ; 82 | 83 | :: translation-party ( text source target -- ) 84 | text dup print [ 85 | dup source target translate dup print 86 | target source translate dup print 87 | swap dupd = not 88 | ] loop drop ; 89 | 90 | : translatortron ( text targets -- ) 91 | dup rest zip [ translate dup print ] assoc-each drop ; 92 | -------------------------------------------------------------------------------- /haikunator/haikunator.factor: -------------------------------------------------------------------------------- 1 | USING: formatting qw random sequences ; 2 | 3 | IN: haikunator 4 | 5 | CONSTANT: adjectives qw{ 6 | autumn hidden bitter misty silent empty dry dark summer icy 7 | delicate quiet white cool spring winter patient twilight 8 | dawn crimson wispy weathered blue billowing broken cold 9 | damp falling frosty green long late lingering bold little 10 | morning muddy old red rough still small sparkling throbbing 11 | shy wandering withered wild black young holy solitary 12 | fragrant aged snowy proud floral restless divine polished 13 | ancient purple lively nameless lucky odd tiny free dry 14 | yellow orange gentle tight super royal broad steep flat 15 | square round mute noisy hushy raspy soft shrill rapid sweet 16 | curly calm jolly fancy plain shinny 17 | } 18 | 19 | CONSTANT: nouns qw{ 20 | waterfall river breeze moon rain wind sea morning snow lake 21 | sunset pine shadow leaf dawn glitter forest hill cloud 22 | meadow sun glade bird brook butterfly bush dew dust field 23 | fire flower firefly feather grass haze mountain night pond 24 | darkness snowflake silence sound sky shape surf thunder 25 | violet water wildflower wave water resonance sun wood dream 26 | cherry tree fog frost voice paper frog smoke star atom band 27 | bar base block boat term credit art fashion truth disk 28 | math unit cell scene heart recipe union limit bread toast 29 | bonus lab mud mode poetry tooth hall king queen lion tiger 30 | penguin kiwi cake mouse rice coke hola salad hat 31 | } 32 | 33 | CONSTANT: token-chars "0123456789" 34 | 35 | : haikunate ( -- str ) 36 | adjectives random 37 | nouns random 38 | 4 [ token-chars random ] "" replicate-as 39 | "%s-%s-%s" sprintf ; 40 | -------------------------------------------------------------------------------- /hangman/words.txt: -------------------------------------------------------------------------------- 1 | prettiest 2 | close 3 | dog 4 | massive 5 | hollow 6 | cultured 7 | seashore 8 | explode 9 | dizzy 10 | minister 11 | competent 12 | thoughtful 13 | harbor 14 | tidy 15 | dance 16 | children 17 | zesty 18 | clean 19 | ball 20 | nostalgic 21 | plan 22 | week 23 | strap 24 | board 25 | slope 26 | bat 27 | steep 28 | mourn 29 | cat 30 | girl 31 | ancient 32 | street 33 | mice 34 | dare 35 | wasteful 36 | tub 37 | limping 38 | whimsical 39 | eager 40 | eggs 41 | detail 42 | experience 43 | beds 44 | train 45 | place 46 | cows 47 | admit 48 | rare 49 | respect 50 | loose 51 | group 52 | enjoy 53 | internal 54 | macabre 55 | imported 56 | superb 57 | crooked 58 | confused 59 | hug 60 | feigned 61 | unkempt 62 | coal 63 | meddle 64 | hapless 65 | country 66 | zealous 67 | sick 68 | pray 69 | lake 70 | tiny 71 | key 72 | empty 73 | labored 74 | delirious 75 | ants 76 | need 77 | omniscient 78 | onerous 79 | damp 80 | subtract 81 | sack 82 | connection 83 | toad 84 | gather 85 | record 86 | new 87 | trashy 88 | flow 89 | river 90 | sparkling 91 | kneel 92 | daughter 93 | glue 94 | allow 95 | raspy 96 | eminent 97 | weak 98 | wrong 99 | pretend 100 | receipt 101 | celery 102 | plain 103 | fire 104 | heal 105 | damaging 106 | honorable 107 | foot 108 | ignorant 109 | substance 110 | box 111 | crime 112 | giant 113 | learned 114 | itchy 115 | smoke 116 | likable 117 | station 118 | jaded 119 | innocent 120 | dead 121 | straw 122 | tray 123 | chin 124 | pack 125 | geese 126 | guess 127 | wealthy 128 | slippery 129 | book 130 | curly 131 | swing 132 | cure 133 | flowers 134 | rate 135 | ignore 136 | insidious 137 | necessary 138 | snakes 139 | entertaining 140 | rich 141 | comb 142 | lamentable 143 | fuel 144 | camera 145 | multiply 146 | army 147 | exist 148 | sulky 149 | brief 150 | worried 151 | third 152 | magical 153 | wary 154 | laborer 155 | end 156 | somber 157 | authority 158 | rainstorm 159 | anxious 160 | purpose 161 | agreeable 162 | spiky 163 | toe 164 | mixed 165 | waiting 166 | hungry 167 | lopsided 168 | flagrant 169 | windy 170 | ground 171 | slap 172 | please 173 | white 174 | hurry 175 | governor 176 | abandoned 177 | reject 178 | spiritual 179 | abrasive 180 | hunt 181 | weather 182 | endurable 183 | hobbies 184 | occur 185 | bake 186 | print 187 | tire 188 | juicy 189 | blush 190 | listen 191 | trousers 192 | daffy 193 | scarecrow 194 | rude 195 | stem 196 | bustling 197 | nail 198 | sneeze 199 | bellicose 200 | love 201 | -------------------------------------------------------------------------------- /happy-numbers/happy-numbers-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: happy-numbers sequences tools.test ; 5 | 6 | [ t ] [ 1 happy? ] unit-test 7 | [ f ] [ 2 happy? ] unit-test 8 | 9 | [ t ] [ 986543210 happy? ] unit-test 10 | [ t ] [ 1234456789 happy? ] unit-test 11 | [ t ] [ 10234456789 happy? ] unit-test 12 | [ t ] [ 13456789298765431 happy? ] unit-test 13 | [ t ] [ 1034567892987654301 happy? ] unit-test 14 | 15 | [ V{ 1 7 10 13 19 23 28 31 32 44 49 } ] 16 | [ 50 [ happy? ] filter ] unit-test 17 | 18 | [ { 1 7 10 13 19 23 28 31 } ] [ 8 happy-numbers ] unit-test 19 | -------------------------------------------------------------------------------- /happy-numbers/happy-numbers.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: combinators kernel make math sequences ; 3 | 4 | IN: happy-numbers 5 | 6 | ] [ [ 10 /mod sq ] dip + ] while nip ; 10 | 11 | : (happy?) ( n1 n2 -- ? ) 12 | [ squares ] [ squares squares ] bi* { 13 | { [ dup 1 = ] [ 2drop t ] } 14 | { [ 2dup = ] [ 2drop f ] } 15 | [ (happy?) ] 16 | } cond ; 17 | 18 | PRIVATE> 19 | 20 | : happy? ( n -- ? ) 21 | dup (happy?) ; 22 | 23 | : happy-numbers ( n -- seq ) 24 | [ 25 | 0 [ over 0 > ] [ 26 | dup happy? [ dup , [ 1 - ] dip ] when 1 + 27 | ] while 2drop 28 | ] { } make ; 29 | 30 | : happy2? ( n -- ? ) 31 | { 32 | { [ dup 1 = ] [ drop t ] } 33 | { [ dup 4 = ] [ drop f ] } 34 | [ squares happy2? ] 35 | } cond ; 36 | 37 | -------------------------------------------------------------------------------- /harshad/harshad.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: fry kernel math math.functions sequences ; 5 | 6 | IN: harshad 7 | 8 | ! http://mathworld.wolfram.com/HarshadNumber.html 9 | 10 | : sum-digits ( n -- x ) 11 | 0 swap [ dup zero? ] [ 10 /mod swap [ + ] dip ] until drop ; 12 | 13 | : next-harshad ( n -- n' ) 14 | [ dup dup sum-digits divisor? ] [ 1 + ] until ; 15 | 16 | : harshad-between ( low high -- seq ) 17 | [ next-harshad ] dip 18 | '[ dup _ <= ] [ [ 1 + next-harshad ] keep ] produce nip ; 19 | 20 | : harshad-upto ( n -- seq ) 21 | 1 swap harshad-between ; 22 | -------------------------------------------------------------------------------- /hello-ga/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /hello-ga/hello-ga-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: hello-ga hello-ga.private tools.test ; 5 | 6 | IN: hello-ga 7 | 8 | [ 0 ] [ TARGET fitness ] unit-test 9 | 10 | [ "" "def" ] [ "abc" "def" 0 head/tail ] unit-test 11 | [ "a" "ef" ] [ "abc" "def" 1 head/tail ] unit-test 12 | [ "ab" "f" ] [ "abc" "def" 2 head/tail ] unit-test 13 | [ "abc" "" ] [ "abc" "def" 3 head/tail ] unit-test 14 | [ "abc" "" ] [ "abc" "def" 0 tail/head ] unit-test 15 | [ "bc" "d" ] [ "abc" "def" 1 tail/head ] unit-test 16 | [ "c" "de" ] [ "abc" "def" 2 tail/head ] unit-test 17 | [ "" "def" ] [ "abc" "def" 3 tail/head ] unit-test 18 | -------------------------------------------------------------------------------- /hello-ga/hello-ga.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: combinators.random fry kernel make math math.order 5 | random ranges sequences ; 6 | 7 | IN: hello-ga 8 | 9 | 10 | CONSTANT: TARGET "Hello World!" 11 | 12 | : fitness ( chromosome -- n ) 13 | TARGET 0 [ - abs - ] 2reduce ; 14 | 15 | CONSTANT: POPULATION 400 16 | 17 | : random-chromosome ( -- chromosome ) 18 | TARGET length [ 256 random ] "" replicate-as ; 19 | 20 | : random-population ( -- seq ) 21 | POPULATION [ random-chromosome ] replicate ; 22 | 23 | CONSTANT: CHILDREN-PROBABILITY 0.9 24 | 25 | : head/tail ( seq1 seq2 n -- head1 tail2 ) 26 | [ head ] [ tail ] bi-curry bi* ; 27 | 28 | : tail/head ( seq1 seq2 n -- tail1 head2 ) 29 | [ tail ] [ head ] bi-curry bi* ; 30 | 31 | : children ( parent1 parent2 -- child1 child2 ) 32 | TARGET length 1 - [1..b) random 33 | [ head/tail append ] [ tail/head prepend ] 3bi ; 34 | 35 | CONSTANT: MUTATION-PROBABILITY 0.2 36 | 37 | : mutate ( chromosome -- chromosome' ) 38 | dup length random over [ -5 5 [a..b] random + ] change-nth ; 39 | 40 | : fittest ( parent1 parent2 -- parent1' parent2' ) 41 | 2dup [ fitness ] bi@ > [ swap ] when ; 42 | 43 | : tournament ( seq -- parent ) 44 | dup [ random ] bi@ fittest nip ; 45 | 46 | : parents ( seq -- parent1 parent2 ) 47 | dup [ tournament ] bi@ ; 48 | 49 | : (1generation) ( seq -- child1 child2 ) 50 | parents CHILDREN-PROBABILITY [ children ] whenp 51 | MUTATION-PROBABILITY [ [ mutate ] bi@ ] whenp ; 52 | 53 | : 1generation ( seq -- seq' ) 54 | [ length 2 / ] keep 55 | '[ _ [ _ (1generation) , , ] times ] { } make ; 56 | 57 | : finished? ( seq -- ? ) 58 | TARGET swap member? ; 59 | 60 | : all-generations ( seq -- seqs ) 61 | [ 62 | [ 1generation dup , dup finished? not ] loop drop 63 | ] { } make ; 64 | -------------------------------------------------------------------------------- /hello-ga/summary.txt: -------------------------------------------------------------------------------- 1 | Genetic "Hello, World!" 2 | -------------------------------------------------------------------------------- /help/search/search.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: arrays assocs formatting help help.markup help.topics io 5 | kernel sequences strings tf-idf ; 6 | 7 | IN: help.search 8 | 9 | assoc ; 15 | 16 | PRIVATE> 17 | 18 | : search-articles ( string -- results ) 19 | all-articles load-article-db search ; 20 | 21 | CONSTANT: max-results 20 22 | 23 | : search. ( string -- ) 24 | search-articles max-results index-or-length head [ 25 | [ \ $link swap 2array ] [ "%.5f" sprintf ] bi* 26 | ] assoc-map $table nl ; 27 | -------------------------------------------------------------------------------- /humanhash/humanhash-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | 3 | IN: humanhash 4 | 5 | { { 205 128 156 96 } } [ 6 | { 96 173 141 13 135 27 96 149 128 130 151 } 4 compress-bytes 7 | ] unit-test 8 | 9 | { "sodium-magnesium-nineteen-hydrogen" } [ 10 | "60ad8d0d871b6095808297" humanhash 11 | ] unit-test 12 | 13 | { "alpha-arizona-avocado-crazy" } [ 14 | B{ 4 8 15 16 23 42 } humanhash 15 | ] unit-test 16 | -------------------------------------------------------------------------------- /icalendar/icalendar.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2012 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel math sequences ; 5 | 6 | IN: icalendar 7 | 8 | 17 | 18 | : content-lines ( string -- lines ) 19 | 0 20 | [ 2dup next-content-line dup ] 21 | [ [ pick subseq ] [ 2 + ] bi swap ] 22 | produce nip [ tail ] dip swap 23 | [ suffix ] unless-empty ; 24 | -------------------------------------------------------------------------------- /ini-file-example/ini-file-example-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: ini-file-example tools.test ; 5 | 6 | IN: ini-file-example.tests 7 | 8 | [ H{ } ] [ "" string>ini ] unit-test 9 | 10 | [ H{ { "section" H{ } } } ] [ "[section]" string>ini ] unit-test 11 | 12 | [ H{ { "section" H{ } } } ] [ "[ section ]" string>ini ] unit-test 13 | 14 | [ H{ { "section" H{ { "foo" "abc def" } } } } ] 15 | [ 16 | """ 17 | [section] 18 | foo = abc def 19 | """ string>ini 20 | ] unit-test 21 | 22 | [ H{ { "section" H{ { "foo" "" } } } } ] 23 | [ 24 | """ 25 | [section] 26 | foo= 27 | """ string>ini 28 | ] unit-test 29 | 30 | [ H{ { "owner" H{ { "name" "John Doe" } 31 | { "organization" "Acme Widgets Inc." } } } 32 | { "database" H{ { "server" "192.0.2.62" } 33 | { "port" "143" } 34 | { "file" "payroll.dat" } } } } ] 35 | [ 36 | """ 37 | # last modified 1 April 2001 by John Doe 38 | [owner] 39 | name=John Doe 40 | organization=Acme Widgets Inc. 41 | 42 | [database] 43 | server=192.0.2.62 # use IP address in case network name resolution is not working 44 | port=143 45 | file = payroll.dat 46 | """ string>ini 47 | ] unit-test 48 | 49 | [ H{ { "a long section name" 50 | H{ { "a long key name" "a long value name" } } } } ] 51 | [ 52 | """ 53 | [a long section name ] 54 | a long key name= a long value name 55 | """ string>ini 56 | ] unit-test 57 | 58 | 59 | -------------------------------------------------------------------------------- /ini-file-example/ini-file-example.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: arrays assocs combinators formatting hashtables io 3 | io.streams.string kernel make math sequences strings 4 | strings.parser ; 5 | 6 | IN: ini-file-example 7 | 8 | : unspace ( str -- str' ) 9 | [ " \t\n\r" member? ] trim ; 10 | 11 | : unwrap ( str -- str' ) 12 | 1 swap [ length 1 - ] keep subseq ; 13 | 14 | : uncomment ( str -- str' ) 15 | CHAR: # over index [ head ] when* ; 16 | 17 | 18 | : section? ( line -- ? ) 19 | [ first CHAR: [ = ] [ last CHAR: ] = ] bi and ; 20 | 21 | : [section] ( line -- section ) 22 | unwrap unspace V{ } clone 2array ; 23 | 24 | : name=value ( section line -- section' ) 25 | CHAR: = over index [ head ] [ 1 + tail ] 2bi 26 | [ unspace ] bi@ 2array over second push ; 27 | 28 | : section, ( section/f -- ) 29 | [ first2 >hashtable 2array , ] when* ; 30 | 31 | : parse-line ( section line -- section' ) 32 | uncomment unspace [ 33 | dup section? 34 | [ swap section, [section] ] [ name=value ] if 35 | ] unless-empty ; 36 | 37 | : read-ini ( -- assoc ) 38 | [ 39 | f [ parse-line ] each-line section, 40 | ] { } make >hashtable ; 41 | 42 | : write-ini ( assoc -- ) 43 | [ 44 | [ "[%s]\n" printf ] dip 45 | [ "%s=%s\n" printf ] assoc-each 46 | nl 47 | ] assoc-each ; 48 | 49 | 50 | : string>ini ( str -- assoc ) 51 | [ read-ini ] with-string-reader ; 52 | 53 | : ini>string ( assoc -- str ) 54 | [ write-ini ] with-string-writer ; 55 | 56 | -------------------------------------------------------------------------------- /insults/insults.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: combinators.random formatting generalizations random ; 3 | 4 | IN: insults 5 | 6 | ! http://was.fm/linguistics/generating_insults 7 | 8 | CONSTANT: animals { 9 | "chicken" "cow" "dog" "donkey" "duck" "goat" "goose" "horse" 10 | "pig" "sheep" "turkey" "fish" "rat" "monkey" 11 | } 12 | 13 | CONSTANT: bodyparts { 14 | "face" "ass" "brain" "cunt" 15 | } 16 | 17 | CONSTANT: obscene { 18 | "shit" "cum" "piss" 19 | } 20 | 21 | CONSTANT: character { 22 | "arrogant" "obnoxious" "surly" "sarcastic" "ignorant" 23 | "guilible" "confused" "immature" "insipid" "stubborn" 24 | "spiteful" "insensitive" "prejudiced" "spoilt" 25 | } 26 | 27 | CONSTANT: imperatives { 28 | "go eat" "go drink" "go lick" "go suck" 29 | } 30 | 31 | : insult ( -- str ) 32 | imperatives obscene character { 33 | [ animals bodyparts ] 34 | [ bodyparts obscene ] 35 | [ obscene animals ] 36 | } call-random [ random ] 5 napply 37 | "%s %s you %s %s%s!" sprintf ; 38 | -------------------------------------------------------------------------------- /iphone-backup/address-book/address-book.factor: -------------------------------------------------------------------------------- 1 | 2 | IN: iphone-backup.address-book 3 | 4 | CONSTANT: address-db "31bb7ba8914766d4ba40d6dfb6113c8b614be442" 5 | -------------------------------------------------------------------------------- /iphone-backup/bookmarks/bookmarks.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs db db.sqlite db.tuples db.types 5 | io.directories io.files.info io.files.unique io.pathnames 6 | iphone-backup kernel sequences sets sorting urls utils ; 7 | 8 | IN: iphone-backup.bookmarks 9 | 10 | CONSTANT: bookmarks-db "d1f062e2da26192a6625d968274bfda8d07821e4" 11 | 12 | : last-bookmarks ( -- path ) 13 | last-backup bookmarks-db append-path ; 14 | 15 | : with-bookmarks-db ( quot -- ) 16 | [ last-bookmarks ] dip with-copy-sqlite-db ; inline 17 | 18 | TUPLE: bookmark id special-id parent type title url num-children 19 | editable? deletable? hidden? hidden-ancestor-count order-index 20 | external-uuid server-id sync-key sync-data deleted? 21 | extra-attributes dav-generation ; 22 | 23 | bookmark "bookmarks" { 24 | { "id" "id" INTEGER } 25 | { "special-id" "special_id" INTEGER } 26 | { "parent" "parent" INTEGER } 27 | { "type" "type" INTEGER } 28 | { "title" "title" TEXT } 29 | { "url" "url" TEXT } 30 | { "num-children" "num_children" INTEGER } 31 | { "editable?" "editable" INTEGER } 32 | { "deletable?" "deletable" INTEGER } 33 | { "hidden?" "hidden" INTEGER } 34 | { "hidden-ancestor-count" "hidden_ancestor_count" INTEGER } 35 | { "order-index" "order_index" INTEGER } 36 | { "external-uuid" "external_uuid" TEXT } 37 | { "server-id" "server_id" TEXT } 38 | { "sync-key" "sync_key" TEXT } 39 | { "sync-data" "sync_data" BLOB } 40 | { "deleted?" "deleted" INTEGER } 41 | { "extra-attributes" "extra_attributes" BLOB } 42 | { "dav-generation" "dav_generation" INTEGER } 43 | } define-persistent 44 | 45 | : count-bookmarks ( -- n ) 46 | T{ bookmark { num-children 0 } } count-tuples ; 47 | 48 | : all-bookmarks ( -- seq ) 49 | T{ bookmark { num-children 0 } } select-tuples ; 50 | 51 | : all-urls ( -- seq ) 52 | all-bookmarks [ [ url>> ] [ title>> ] bi ] { } map>assoc ; 53 | 54 | : all-domains ( -- seq ) 55 | all-bookmarks [ url>> >url host>> ] map members ; 56 | -------------------------------------------------------------------------------- /iphone-backup/calendar/calendar.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors assocs db db.sqlite db.tuples db.types 5 | io.directories io.files.info io.files.unique io.pathnames 6 | iphone-backup kernel sequences sets sorting urls utils ; 7 | 8 | IN: iphone-backup.calendar 9 | 10 | CONSTANT: calendar-db "2041457d5fe04d39d0ab481178355df6781e6858" 11 | 12 | : last-calendar ( -- path ) 13 | last-backup calendar-db append-path ; 14 | 15 | : with-calendar-db ( quot -- ) 16 | [ last-calendar ] dip with-copy-sqlite-db ; inline 17 | 18 | TUPLE: event rowid summary location description start-date 19 | start-tz end-date all-day? calendar-id orig-event-id 20 | orig-start-date organizer-id organizer-is-self? 21 | organizer-external-id self-attendee-id status availability 22 | privacy-level url last-modified sequence-num birthday-id 23 | modified-properties external-tracking-status external-id 24 | external-mod-tag unique-identifier external-schedule-id 25 | external-rep response-comment hidden? ; 26 | -------------------------------------------------------------------------------- /iphone-backup/iphone-backup.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors db db.sqlite db.tuples db.types io.directories 5 | io.files.info io.files.temp io.files.unique io.pathnames kernel 6 | sequences sorting utils ; 7 | 8 | IN: iphone-backup 9 | 10 | ! CONSTANT: text-messages "3d0d7e5fb2ce288813306e4d4636395e047a3d28" 11 | ! CONSTANT: address-book "31bb7ba8914766d4ba40d6dfb6113c8b614be442" 12 | ! CONSTANT: locations "4096c9ec676f2847dc283405900e284a7c815836" 13 | ! CONSTANT: web-cookies "462db712aa8d833ff164035c1244726c477891bd" 14 | ! CONSTANT: phone-db "790885a13b24eabcce43db750d654a228fc2395b" 15 | ! CONSTANT: voicemails "992df473bbb9e132f4b3b6e4d33f72171e97bc7a" 16 | ! CONSTANT: photos "bedec6d42efe57123676bfa31e98ab68b713195f" 17 | 18 | : last-modified ( path -- path' ) 19 | [ 20 | [ file-info modified>> ] sort-with last 21 | ] with-directory-files ; 22 | 23 | : last-backup ( -- path ) 24 | home "Library/Application Support/MobileSync/Backup" 25 | append-path dup last-modified append-path ; 26 | 27 | : ( path -- sqlite-db ) 28 | temp-file [ copy-file ] [ ] bi ; 29 | 30 | : with-copy-sqlite-db ( path quot -- ) 31 | [ ] dip with-db ; inline 32 | 33 | -------------------------------------------------------------------------------- /ipinfodb/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /ipinfodb/ipinfodb-docs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2009 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: help.syntax help.markup ipinfodb sequences strings ; 5 | 6 | IN: ipinfodb 7 | 8 | HELP: locate-my-ip 9 | { $description 10 | "Returns a tuple representing the geolocation of the callers IP address." 11 | } ; 12 | 13 | HELP: locate-ip 14 | { $values { "ip" string } { "info" ip-info } } 15 | { $description 16 | "Returns a tuple representing the geolocation of the specified IP address." 17 | } ; 18 | 19 | HELP: locate-ips 20 | { $values { "ips" sequence } { "infos" sequence } } 21 | { $description 22 | "Returns a sequence of tuples representing the geolocation of the " 23 | "specified IP addresses." 24 | } ; 25 | 26 | HELP: locate-ip2 27 | { $values { "ip/domain" string } { "info" ip-info } } 28 | { $description 29 | "Returns a tuple representing the geolocation of the specified IP " 30 | "address or domain name." 31 | } ; 32 | 33 | -------------------------------------------------------------------------------- /ipinfodb/ipinfodb.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2009 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors combinators fry http.client io kernel 5 | quotations sequences xml xml.traversal ; 6 | 7 | IN: ipinfodb 8 | 9 | TUPLE: ip-info ip country-code country-name 10 | region-code region-name city zip-code 11 | latitude longitude gmtoffset dstoffset ; 12 | 13 | string ; inline 17 | 18 | : xml>ip-info ( xml -- info ) 19 | [ ip-info new ] dip 20 | { 21 | [ "Ip" find-tag >>ip ] 22 | [ "CountryCode" find-tag >>country-code ] 23 | [ "CountryName" find-tag >>country-name ] 24 | [ "RegionCode" find-tag >>region-code ] 25 | [ "RegionName" find-tag >>region-name ] 26 | [ "City" find-tag >>city ] 27 | [ "ZipPostalCode" find-tag >>zip-code ] 28 | [ "Latitude" find-tag >>latitude ] 29 | [ "Longitude" find-tag >>longitude ] 30 | [ "Gmtoffset" find-tag >>gmtoffset ] 31 | [ "Dstoffset" find-tag >>dstoffset ] 32 | } cleave ; 33 | 34 | PRIVATE> 35 | 36 | : locate-my-ip ( -- info ) 37 | "http://ipinfodb.com/ip_query.php" http-get 38 | string>xml xml>ip-info nip ; 39 | 40 | : locate-ip ( ip -- info ) 41 | "http://ipinfodb.com/ip_query.php?ip=" prepend http-get 42 | string>xml xml>ip-info nip ; 43 | 44 | : locate-ips ( ips -- infos ) 45 | "," join "http://ipinfodb.com/ip_query2.php?ip=" prepend 46 | http-get string>xml children-tags [ xml>ip-info ] { } map-as nip ; 47 | 48 | : locate-ip2 ( ip/domain -- info ) 49 | "http://ipinfodb.com/ip_query2.php?ip=" prepend http-get 50 | string>xml xml>ip-info nip ; 51 | 52 | -------------------------------------------------------------------------------- /ipinfodb/summary.txt: -------------------------------------------------------------------------------- 1 | IP address geolocation tools. 2 | -------------------------------------------------------------------------------- /isbn/isbn-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | IN: isbn 3 | 4 | { t } [ "0-306-40615-2" valid-isbn? ] unit-test 5 | { t } [ "978-0-306-40615-7" valid-isbn? ] unit-test 6 | 7 | { 2 } [ "0-306-40615-?" calc-isbn-10-check ] unit-test 8 | { 7 } [ "978-0-306-40615-?" calc-isbn-13-check ] unit-test 9 | 10 | -------------------------------------------------------------------------------- /isbn/isbn.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: ascii combinators kernel math math.parser sequences ; 3 | 4 | IN: isbn 5 | 6 | : digits ( str -- digits ) 7 | [ digit? ] filter string>digits ; 8 | 9 | : isbn-10-check ( digits -- n ) 10 | 0 [ 10 swap - * + ] reduce-index 11 mod ; 11 | 12 | : isbn-13-check ( digits -- n ) 13 | 0 [ even? 1 3 ? * + ] reduce-index 10 mod ; 14 | 15 | : valid-isbn? ( str -- ? ) 16 | digits dup length { 17 | { 10 [ isbn-10-check ] } 18 | { 13 [ isbn-13-check ] } 19 | } case 0 = ; 20 | 21 | : calc-isbn-10-check ( str -- check ) 22 | digits isbn-10-check 11 swap - ; 23 | 24 | : calc-isbn-13-check ( str -- check ) 25 | digits isbn-13-check 10 swap - ; 26 | -------------------------------------------------------------------------------- /js-arrays/js-arrays.factor: -------------------------------------------------------------------------------- 1 | USING: accessors delegate delegate.protocols kernel ; 2 | 3 | IN: js-arrays 4 | 5 | TUPLE: js-array seq assoc ; 6 | 7 | : ( -- js-array ) 8 | V{ } clone H{ } clone js-array boa ; 9 | 10 | INSTANCE: js-array sequence 11 | 12 | CONSULT: sequence-protocol js-array seq>> ; 13 | 14 | INSTANCE: js-array assoc 15 | 16 | CONSULT: assoc-protocol js-array assoc>> ; 17 | -------------------------------------------------------------------------------- /k-nn/k-nn.factor: -------------------------------------------------------------------------------- 1 | USING: arrays byte-arrays formatting fry io.encodings.ascii 2 | io.files kernel kernel.private math math.parser sequences 3 | sequences.extras splitting ; 4 | 5 | IN: k-nn 6 | 7 | : slurp-file ( path -- {pixels,label} ) 8 | ascii file-lines rest [ 9 | "," split [ string>number ] B{ } map-as unclip 2array 10 | ] map ; 11 | 12 | : distance ( x y -- z ) 13 | { byte-array byte-array } declare 0 [ - sq + ] 2reduce ; 14 | 15 | : classify ( training pixels -- label ) 16 | '[ first _ distance ] infimum-by second ; 17 | 18 | : validate ( training validation -- % ) 19 | [ first2 [ classify ] [ = ] bi* ] with percent-of ; 20 | 21 | : k-nn ( -- ) 22 | "vocab:k-nn/trainingsample.csv" slurp-file 23 | "vocab:k-nn/validationsample.csv" slurp-file 24 | validate 100.0 * "Percentage correct: %f\n" printf ; 25 | -------------------------------------------------------------------------------- /magic-forest/magic-forest.factor: -------------------------------------------------------------------------------- 1 | USING: accessors arrays classes.tuple combinators.short-circuit 2 | command-line hash-sets kernel math math.order math.parser 3 | namespaces prettyprint sequences sets ; 4 | 5 | IN: magic-forest 6 | 7 | ! brute force 8 | 9 | TUPLE: forest goats wolves lions ; 10 | 11 | C: forest 12 | 13 | : >forest< ( forest -- goats wolves lions ) 14 | [ goats>> ] [ wolves>> ] [ lions>> ] tri ; 15 | 16 | : wolf-devours-goat ( forest -- forest/f ) 17 | >forest< { [ pick 0 > ] [ over 0 > ] } 0&& 18 | [ [ 1 - ] [ 1 - ] [ 1 + ] tri* ] [ 3drop f ] if ; 19 | 20 | : lion-devours-goat ( forest -- forest/f ) 21 | >forest< { [ pick 0 > ] [ dup 0 > ] } 0&& 22 | [ [ 1 - ] [ 1 + ] [ 1 - ] tri* ] [ 3drop f ] if ; 23 | 24 | : lion-devours-wolf ( forest -- forest/f ) 25 | >forest< { [ dup 0 > ] [ over 0 > ] } 0&& 26 | [ [ 1 + ] [ 1 - ] [ 1 - ] tri* ] [ 3drop f ] if ; 27 | 28 | : next-forests ( set forest -- set' ) 29 | [ wolf-devours-goat [ over adjoin ] when* ] 30 | [ lion-devours-goat [ over adjoin ] when* ] 31 | [ lion-devours-wolf [ over adjoin ] when* ] tri ; 32 | 33 | : meal ( forests -- forests' ) 34 | [ length 3 * ] keep [ next-forests ] each members ; 35 | 36 | : stable? ( forest -- ? ) 37 | >forest< rot zero? [ [ zero? ] either? ] [ [ zero? ] both? ] if ; 38 | 39 | : devouring-possible? ( forests -- ? ) 40 | [ stable? ] none? ; 41 | 42 | : stable-forests ( forests -- stable-forests ) 43 | [ stable? ] filter ; 44 | 45 | : find-stable-forests ( forest -- forests ) 46 | 1array [ dup devouring-possible? ] [ meal ] while stable-forests ; 47 | 48 | : super-fast-find-stable-animals ( forest -- n ) 49 | >forest< min + ; 50 | 51 | 52 | MAIN: [ 53 | command-line get [ string>number ] map forest slots>tuple 54 | find-stable-forests . 55 | ] 56 | -------------------------------------------------------------------------------- /mail-ui/mail-ui.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors arrays colors kernel sequences smtp splitting 5 | ui ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons 6 | ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.toolbar ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens.solid ui.theme ui.tools.common ; 7 | 8 | IN: mail-ui 9 | 10 | ( -- editor ) 15 | tabbing-editor new-editor ; 16 | 17 | TUPLE: tabbing-multiline-editor < multiline-editor next-editor prev-editor ; 18 | 19 | : ( -- editor ) 20 | tabbing-multiline-editor new-editor ; 21 | 22 | : com-prev ( editor -- ) 23 | prev-editor>> [ request-focus ] when* ; 24 | 25 | : com-next ( editor -- ) 26 | next-editor>> [ request-focus ] when* ; 27 | 28 | tabbing-editor tabbing-multiline-editor [ 29 | "editing" f { 30 | { T{ key-down f f "TAB" } com-next } 31 | { T{ key-down f { S+ } "TAB" } com-prev } 32 | } define-command-map 33 | ] bi@ 34 | 35 | PRIVATE> 36 | 37 | TUPLE: mail-gadget < track to subject body ; 38 | 39 | M: mail-gadget focusable-child* to>> ; 40 | 41 | : ( mail -- gadget ) 42 | to>> "To:" label-on-left ; 43 | 44 | : ( mail -- gadget ) 45 | subject>> "Subject:" label-on-left ; 46 | 47 | : ( mail -- gadget ) 48 | body>> field-border-color >>boundary ; 49 | 50 | 57 | 58 | : com-send ( mail -- ) 59 | 60 | over to>> editor-string " " split harvest >>to 61 | over subject>> editor-string >>subject 62 | over body>> editor-string >>body 63 | send-email maybe-close-window ; 64 | 65 | : com-cancel ( mail -- ) 66 | maybe-close-window ; 67 | 68 | mail-gadget "toolbar" f { 69 | { f com-send } 70 | { f com-cancel } 71 | } define-command-map 72 | 73 | : ( -- gadget ) 74 | vertical mail-gadget new-track 75 | 1 >>fill 76 | { 10 10 } >>gap 77 | 78 | >>to 79 | >>subject 80 | 81 | 10 >>min-rows 82 | 60 >>min-cols 83 | >>body 84 | 85 | dup to>> over subject>> >>next-editor drop 86 | dup to>> over body>> >>prev-editor drop 87 | 88 | dup subject>> over body>> >>next-editor drop 89 | dup subject>> over to>> >>prev-editor drop 90 | 91 | dup body>> over subject>> >>prev-editor drop 92 | 93 | dup f track-add 94 | dup f track-add 95 | dup 1 track-add 96 | dup f track-add ; 97 | 98 | : open-compose-window ( -- ) 99 | 100 | { 5 5 } { 1 1 } >>fill white-interior 101 | "Compose" open-window ; 102 | -------------------------------------------------------------------------------- /missing-assocs/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /missing-assocs/missing-assocs-tests.factor: -------------------------------------------------------------------------------- 1 | USING: assocs kernel math sequences tools.test ; 2 | IN: missing-assocs 3 | 4 | { 2 } [ 5 | 8 [ 2 * ] 1 of 6 | ] unit-test 7 | 8 | { { { 1 V{ 2 } } { 2 V{ 4 } } } } [ 9 | 8 [ V{ } clone ] 10 | [ 1 [ of ] [ 2 * swap push ] bi ] 11 | [ 2 [ of ] [ 2 * swap push ] bi ] 12 | [ >alist ] tri 13 | ] unit-test 14 | -------------------------------------------------------------------------------- /missing-assocs/missing-assocs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | USING: accessors assocs hashtables kernel ; 4 | IN: missing-assocs 5 | 6 | TUPLE: missing-assoc assoc quot ; 7 | 8 | : ( assoc quot: ( key -- value ) -- missing-assoc ) 9 | missing-assoc boa ; inline 10 | 11 | : ( capacity quot: ( key -- value ) -- missing-assoc ) 12 | [ ] dip ; inline 13 | 14 | : ( assoc quot: ( -- value ) -- default-assoc ) 15 | [ drop ] prepose ; inline 16 | 17 | : ( capacity quot: ( -- value ) -- default-assoc ) 18 | [ drop ] prepose ; inline 19 | 20 | M: missing-assoc at* 21 | [ assoc>> at* ] 2keep pick [ 2drop ] [ 22 | [ 2drop ] 2dip 23 | [ dupd quot>> call( key -- value ) swap ] 24 | [ [ assoc>> set-at ] 3keep 2drop t ] bi 25 | ] if ; 26 | 27 | M: missing-assoc set-at assoc>> set-at ; inline 28 | M: missing-assoc delete-at assoc>> delete-at ; inline 29 | M: missing-assoc >alist assoc>> >alist ; inline 30 | M: missing-assoc keys assoc>> keys ; inline 31 | M: missing-assoc values assoc>> values ; inline 32 | M: missing-assoc assoc-size assoc>> assoc-size ; inline 33 | M: missing-assoc clear-assoc assoc>> clear-assoc ; inline 34 | 35 | INSTANCE: missing-assoc assoc 36 | -------------------------------------------------------------------------------- /misspell/misspell.factor: -------------------------------------------------------------------------------- 1 | USING: ascii combinators.short-circuit io kernel math 2 | random ranges sequences splitting ; 3 | 4 | IN: mispell 5 | 6 | : misspell-word ( word -- word' ) 7 | dup [ ",'.:;!?" member? not ] find-last drop 0 or 8 | dup 2 > [ 9 | dupd head-slice dup [ Letter? ] all? 10 | [ rest-slice randomize ] when drop 11 | ] [ drop ] if ; 12 | 13 | : misspell-line ( line -- line' ) 14 | [ blank? ] split-when [ misspell-word ] map " " join ; 15 | 16 | : misspell ( string -- string' ) 17 | string-lines [ misspell-line ] map "\n" join ; 18 | 19 | : misspell-main ( -- ) 20 | " 21 | According to research at an English University, it doesn't matter 22 | in what order the letters in a word are, the only important thing is 23 | that the first and last letters be in the right places. The rest can 24 | be a total mess and you can still read it without problem. This is 25 | because the human mind does not read every letter by itself, but 26 | the word as a whole. 27 | " misspell print ; 28 | 29 | MAIN: misspell-main 30 | -------------------------------------------------------------------------------- /monte-carlo/monte-carlo.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: fry kernel math math.functions math.statistics namespaces 3 | random random.private sequences ; 4 | 5 | IN: monte-carlo 6 | 7 | ! I’m going to propose a contract: I will flip a coin ten times, 8 | ! and if I get three heads in a row I will give you $1. How much 9 | ! will you pay me to enter into that contract? 10 | 11 | : 10-flips ( -- seq ) 12 | 10 [ random-unit 0.5 > ] replicate ; 13 | 14 | : payoff ( -- n ) 15 | { t t t } 10-flips subseq? 1.0 0.0 ? ; 16 | 17 | : contract-value ( flips -- value-estimate ) 18 | [ payoff ] replicate mean ; 19 | 20 | ! Estimate pi 21 | 22 | : random-point* ( obj -- x y ) 23 | [ random-unit* ] [ random-unit* ] bi ; 24 | 25 | : random-point ( -- x y ) 26 | random-generator get random-point* ; 27 | 28 | : inside-circle? ( x y -- ? ) 29 | [ sq ] bi@ + sqrt 1.0 <= ; 30 | 31 | : estimate-pi ( points -- pi-estimate ) 32 | 0 swap [ 33 | random-generator get 34 | '[ 35 | _ random-point* inside-circle? [ 1 + ] when 36 | ] times 37 | ] keep /f 4 * ; 38 | -------------------------------------------------------------------------------- /mysql/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /mysql/errors/errors.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: db.errors kernel multiline peg.ebnf quoting strings ; 5 | 6 | IN: mysql.errors 7 | 8 | EBNF: parse-mysql-sql-error [=[ 9 | 10 | TableError = 11 | "Table '" (!("'").)+:table "' already exists" 12 | => [[ table >string unquote ]] 13 | | "Table '" (!("'").)+:table "' doesn't exist" 14 | => [[ table >string unquote ]] 15 | | "Unknown table '" (!("'").)+:table "'" 16 | => [[ table >string unquote ]] 17 | 18 | SyntaxError = 19 | "You have an error in your SQL syntax":error 20 | => [[ error >string ]] 21 | 22 | UnknownError = .* => [[ >string ]] 23 | 24 | MysqlSqlError = (TableError | SyntaxError | UnknownError) 25 | 26 | ]=] 27 | 28 | 29 | -------------------------------------------------------------------------------- /mysql/summary.txt: -------------------------------------------------------------------------------- 1 | MySQL database connector 2 | -------------------------------------------------------------------------------- /n-numbers/n-numbers-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: tools.test ; 3 | 4 | IN: n-numbers 5 | 6 | { f } [ "N0" n-number? ] unit-test 7 | { t } [ "N1" n-number? ] unit-test 8 | { f } [ "N1I" n-number? ] unit-test 9 | { t } [ "N123AZ" n-number? ] unit-test 10 | { t } [ "N1234Z" n-number? ] unit-test 11 | { t } [ "N12345" n-number? ] unit-test 12 | -------------------------------------------------------------------------------- /n-numbers/n-numbers.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: ascii combinators.short-circuit kernel math.order 5 | sequences splitting ; 6 | 7 | IN: n-numbers 8 | 9 | ! may not begin with zero (0). 10 | ! may not be the letters "I" or "O" to avoid confusion 11 | ! with the numbers one (1) or zero (0). 12 | : (n-number?) ( digits letters -- ? ) 13 | [ dup first CHAR: 0 = [ drop f ] [ [ digit? ] all? ] if ] 14 | [ [ [ Letter? ] [ "IiOo" member? not ] bi and ] all? ] 15 | bi* and ; 16 | 17 | ! may be one (1) to five (5) numbers (e.g. N12345); 18 | ! may be one (1) to four (4) numbers and one (1) suffix letter 19 | ! (examples: N1A and N1234Z); 20 | ! may be one (1) to three (3) numbers and two (2) suffix letters 21 | ! (examples: N24BY and N123AZ). 22 | : n-number? ( str -- ? ) 23 | "N" ?head drop { 24 | [ { [ length 1 5 between? ] [ f (n-number?) ] } 1&& ] 25 | [ { [ length 2 5 between? ] [ 1 cut* (n-number?) ] } 1&& ] 26 | [ { [ length 3 5 between? ] [ 2 cut* (n-number?) ] } 1&& ] 27 | } 1|| ; 28 | 29 | ! Registration numbers N1 through N99 are reserved for Federal 30 | ! Aviation Administration (FAA) internal use and are not 31 | ! available. 32 | : reserved? ( str -- ? ) 33 | "N" ?head drop 34 | { [ length 1 2 between? ] [ [ digit? ] all? ] } 1&& ; 35 | 36 | H{ 37 | { CHAR: A "4" } 38 | { CHAR: B "86" } 39 | { CHAR: E "3" } 40 | { CHAR: 6 "69" } 41 | { CHAR: I "1" } 42 | { CHAR: J "1" } 43 | { CHAR: L "17" } 44 | { CHAR: O "0" } 45 | { CHAR: P "9" } 46 | { CHAR: Q "92" } 47 | { CHAR: S "52" } 48 | { CHAR: T "7" } 49 | { CHAR: Y "7" } 50 | { CHAR: 2 "Z" } 51 | } drop 52 | -------------------------------------------------------------------------------- /n-partition/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /n-partition/n-partition-docs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: help.markup help.syntax ; 5 | 6 | IN: n-partition 7 | 8 | HELP: n-partition 9 | { $values 10 | { "amount" "a number of amount" } 11 | { "n" "a number of buckets" } 12 | { "seq" "a sequence" } 13 | } 14 | { $description 15 | "Partition an integer evenly into 'n' buckets. Returns a list " 16 | "of 'n' integers that sum to 'x'." 17 | } 18 | { $examples 19 | { $example 20 | "USING: n-partition ;" 21 | "3 1 n-partition" 22 | "{ 3 }" } 23 | { $example 24 | "USING: n-partition ;" 25 | "3 3 n-partition" 26 | "{ 1 1 1 }" } 27 | { $example 28 | "USING: n-partition ;" 29 | "5 3 n-partition" 30 | "{ 2 1 2 }" } 31 | { $example 32 | "USING: n-partition ;" 33 | "3 5 n-partition" 34 | "{ 1 0 1 0 1 }" } 35 | { $example 36 | "USING: n-partition ;" 37 | "1000 7 n-partition" 38 | "{ 143 143 143 142 143 143 143 }" } 39 | } ; 40 | 41 | -------------------------------------------------------------------------------- /n-partition/n-partition-tests.factor: -------------------------------------------------------------------------------- 1 | USING: n-partition tools.test ; 2 | 3 | IN: n-partition.tests 4 | 5 | [ { 3 } ] [ 3 1 n-partition ] unit-test 6 | [ { 1 1 1 } ] [ 3 3 n-partition ] unit-test 7 | [ { 2 1 2 } ] [ 5 3 n-partition ] unit-test 8 | [ { 1 0 1 0 1 } ] [ 3 5 n-partition ] unit-test 9 | [ { 143 143 143 142 143 143 143 } ] [ 1000 7 n-partition ] unit-test 10 | 11 | -------------------------------------------------------------------------------- /n-partition/n-partition.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: arrays assocs kernel grouping sequences shuffle 5 | math math.functions math.statistics math.vectors ranges ; 6 | 7 | IN: n-partition 8 | 9 | 20 | 21 | : n-partition ( x n -- seq ) steps rounded differences ; 22 | -------------------------------------------------------------------------------- /n-partition/summary.txt: -------------------------------------------------------------------------------- 1 | Evenly partition an integer. 2 | -------------------------------------------------------------------------------- /pagination/pagination-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | IN: pagination 3 | 4 | { { 1 2 3 99 100 } } [ 1 100 pages-to-show ] unit-test 5 | { { 1 2 21 22 23 24 25 27 28 } } [ 23 28 pages-to-show ] unit-test 6 | { { 1 2 3 } } [ 1 3 pages-to-show ] unit-test 7 | -------------------------------------------------------------------------------- /pagination/pagination.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2014 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: combinators combinators.smart io kernel locals math 5 | math.order math.parser sequences sets splitting.monotonic ; 6 | 7 | IN: pagination 8 | 9 | :: pages-to-show ( page #pages -- seq ) 10 | [ 11 | 1 2 page { 12 | [ 2 - ] 13 | [ 1 - ] 14 | [ ] 15 | [ 1 + ] 16 | [ 2 + ] 17 | } cleave #pages [ 1 - ] keep 18 | ] output>array members 19 | [ 1 #pages between? ] filter ; 20 | 21 | 22 | :: pages-to-show. ( page #pages -- ) 23 | page #pages pages-to-show 24 | [ swap - 1 = ] monotonic-split { f } join 25 | [ 26 | [ 27 | [ number>string ] 28 | [ page = [ "[" "]" surround ] when ] bi 29 | ] [ "..." ] if* 30 | ] map " " join "<< " " >>" surround print ; 31 | -------------------------------------------------------------------------------- /palindrome/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-c-types? f } 4 | { deploy-word-props? f } 5 | { deploy-name "palindrome" } 6 | { deploy-word-defs? f } 7 | { deploy-compiler? t } 8 | { deploy-reflection 1 } 9 | { deploy-io 1 } 10 | { deploy-random? t } 11 | { deploy-math? t } 12 | { "stop-after-last-window?" t } 13 | { deploy-ui? f } 14 | { deploy-threads? t } 15 | } 16 | -------------------------------------------------------------------------------- /palindrome/palindrome-docs.factor: -------------------------------------------------------------------------------- 1 | USING: palindrome help.markup help.syntax strings ; 2 | 3 | IN: palindrome 4 | 5 | HELP: palindrome? 6 | { $syntax "text palindrome?" } 7 | { $values { "text" "a string to be tested" } } 8 | { $description "Tests a string for palindrome-ness." } 9 | { $examples 10 | { $example 11 | "USING: palindrome ;" 12 | "\"racecar\" palindrome?" 13 | "t" } 14 | } ; 15 | 16 | -------------------------------------------------------------------------------- /palindrome/palindrome-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: palindrome tools.test ; 5 | 6 | [ f ] [ "hello" palindrome? ] unit-test 7 | [ t ] [ "racecar" palindrome? ] unit-test 8 | [ t ] [ "A man, a plan, a canal: Panama." palindrome? ] unit-test 9 | 10 | -------------------------------------------------------------------------------- /palindrome/palindrome.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2008 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel morse prettyprint sequences unicode ; 5 | 6 | IN: palindrome 7 | 8 | : normalize ( str -- str' ) [ Letter? ] filter >lower ; 9 | 10 | : palindrome? ( str -- ? ) normalize dup reverse = ; 11 | 12 | : main ( -- ) "racecar" palindrome? . ; 13 | 14 | : normalize-morse ( str -- str' ) 15 | normalize >morse [ blank? ] reject ; 16 | 17 | : morse-palindrome? ( str -- ? ) 18 | normalize-morse dup reverse = ; 19 | 20 | MAIN: main 21 | 22 | -------------------------------------------------------------------------------- /pdf/examples/examples.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USE: accessors 5 | USE: assocs 6 | USE: colors 7 | USE: colors.gray 8 | USE: fonts 9 | USE: hashtables 10 | USE: help 11 | USE: help.apropos 12 | USE: help.markup 13 | USE: help.pdf 14 | USE: io 15 | USE: io.encodings.utf8 16 | USE: io.files 17 | USE: io.styles 18 | USE: kernel 19 | USE: math 20 | USE: pdf 21 | USE: pdf.layout 22 | USE: pdf.streams 23 | USE: sequences 24 | 25 | IN: pdf.examples 26 | 27 | string write-foo-pdf ; 34 | 35 | PRIVATE> 36 | 37 | : test1-pdf ( -- ) 38 | [ "Hello, world" print ] with-pdf-writer foo-pdf ; 39 | 40 | : test2-pdf ( -- ) 41 | [ "does “this” work?" print ] with-pdf-writer foo-pdf ; 42 | 43 | : test3-pdf ( -- ) 44 | [ "http" apropos ] with-pdf-writer foo-pdf ; 45 | 46 | : test4-pdf ( -- ) 47 | [ 48 | 10 [ 49 | "Hello world\n" 50 | swap 10 / 1 foreground associate format 51 | ] each 52 | ] with-pdf-writer foo-pdf ; 53 | 54 | USE: literals 55 | 56 | : test5-pdf ( -- ) 57 | [ 58 | { $ sans-serif-font $ serif-font $ monospace-font } [ 59 | name>> font-name associate 60 | { plain bold italic bold-italic } [ 61 | [ name>> ] [ 62 | font-style associate pick assoc-union 63 | ] bi format nl 64 | ] each drop nl 65 | ] each 66 | ] with-pdf-writer foo-pdf ; 67 | 68 | : test6-pdf ( -- ) 69 | "/Users/jbenedik/Dev/re-factor/text-to-pdf/text-to-pdf.factor" 70 | utf8 file-contents text-to-pdf foo-pdf ; 71 | 72 | : test7-pdf ( -- ) 73 | [ "sequences" print-topic ] with-pdf-writer foo-pdf ; 74 | 75 | : test8-pdf ( -- ) 76 | [ 77 | "does " write 78 | "this" COLOR: gray background associate format 79 | " work?" write 80 | ] with-pdf-writer foo-pdf ; 81 | 82 | : test9-pdf ( -- ) 83 | [ 84 | "Some " write 85 | H{ { inset { 10 10 } } { page-color COLOR: light-gray } } 86 | [ "inset" write ] with-nesting 87 | " text" write 88 | ] with-pdf-writer foo-pdf ; 89 | 90 | : test10-pdf ( -- ) 91 | [ 92 | { 12 18 24 72 } 93 | [ "Bigger" swap font-size associate format ] each 94 | nl 95 | { 12 18 24 72 } 96 | [ "Bigger" swap font-size associate format ] each 97 | ] with-pdf-writer foo-pdf ; 98 | 99 | : test11-pdf ( -- ) 100 | [ 101 | { $table { "some" "longer" "c" } { "text" "e" "f" } } 102 | print-element 103 | ] with-pdf-writer foo-pdf ; 104 | 105 | : test12-pdf ( -- ) 106 | [ 107 | { $table 108 | { "some" "longer" } 109 | { "text" { } } 110 | } 111 | print-element 112 | ] with-pdf-writer foo-pdf ; 113 | -------------------------------------------------------------------------------- /periodic-words/periodic-words-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: periodic-words tools.test ; 5 | 6 | IN: periodic-words 7 | 8 | [ t ] [ "Genius" periodic? ] unit-test 9 | [ f ] [ "Factor" periodic? ] unit-test 10 | -------------------------------------------------------------------------------- /pig-latin/pig-latin-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | IN: pig-latin 3 | 4 | { "igpay" } [ "pig" pig-latin ] unit-test 5 | { "ananabay" } [ "banana" pig-latin ] unit-test 6 | { "ashtray" } [ "trash" pig-latin ] unit-test 7 | { "appyhay" } [ "happy" pig-latin ] unit-test 8 | { "uckday" } [ "duck" pig-latin ] unit-test 9 | { "oveglay" } [ "glove" pig-latin ] unit-test 10 | 11 | { "eggway" } [ "egg" pig-latin ] unit-test 12 | { "inboxway" } [ "inbox" pig-latin ] unit-test 13 | { "eightway" } [ "eight" pig-latin ] unit-test 14 | -------------------------------------------------------------------------------- /pig-latin/pig-latin.factor: -------------------------------------------------------------------------------- 1 | USING: ascii kernel math sequences ; 2 | 3 | IN: pig-latin 4 | 5 | : vowel? ( ch -- ? ) ch>lower "aeiou" member? ; 6 | 7 | : pig-latin ( str -- str' ) 8 | dup [ vowel? ] find [ 9 | [ 10 | "way" append 11 | ] [ 12 | cut swap "ay" 3append 13 | ] if-zero 14 | ] [ drop ] if ; 15 | -------------------------------------------------------------------------------- /plagiarism/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-name "plagiarism" } 4 | { deploy-ui? f } 5 | { deploy-c-types? t } 6 | { deploy-console? t } 7 | { deploy-unicode? f } 8 | { "stop-after-last-window?" t } 9 | { deploy-io 3 } 10 | { deploy-reflection 6 } 11 | { deploy-word-props? t } 12 | { deploy-math? t } 13 | { deploy-threads? t } 14 | { deploy-word-defs? t } 15 | } 16 | -------------------------------------------------------------------------------- /plagiarism/plagiarism-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: plagiarism tools.test ; 5 | 6 | IN: plagiarism 7 | 8 | [ "this is a really LONG PIECE OF TEXT" ] [ 9 | "this is a really long piece of text" 10 | { "this is a long piece of text" } 11 | 4 detect-plagiarism 12 | ] unit-test 13 | -------------------------------------------------------------------------------- /plagiarism/plagiarism.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: command-line grouping io io.encodings.utf8 io.files 5 | kernel math math.parser namespaces ranges regexp sequences 6 | sequences.extras sets splitting unicode utils ; 7 | 8 | IN: plagiarism 9 | 10 | : n-grams ( str n -- seq ) 11 | [ [ blank? ] split-when harvest ] [ ] bi* ; 12 | 13 | : common-n-grams ( suspect sources n -- n-grams ) 14 | [ n-grams ] curry dup [ map concat ] curry bi* intersect ; 15 | 16 | : n-gram>regexp ( seq -- regexp ) 17 | [ [ Letter? not ] split-when "[\\W\\S]" join ] map 18 | "\\s+" join "(\\s|^)" "(\\s|$)" surround 19 | "i" ; 20 | 21 | : upper-matches ( str regexp -- ) 22 | [ [ [a..b) ] dip [ ch>upper ] change-nths ] each-match ; 23 | 24 | : detect-plagiarism ( suspect sources n -- suspect' ) 25 | [ dupd ] dip common-n-grams [ 26 | dupd n-gram>regexp upper-matches 27 | ] each ; 28 | 29 | : run-plagiarism ( -- ) 30 | command-line get dup length 3 < [ 31 | drop "USAGE: plagiarism N suspect.txt source.txt..." print 32 | ] [ 33 | [ rest [ utf8 file-contents ] map unclip swap ] 34 | [ first string>number ] bi detect-plagiarism print 35 | ] if ; 36 | 37 | MAIN: run-plagiarism 38 | -------------------------------------------------------------------------------- /port-scan/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /port-scan/port-scan.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: continuations formatting io.encodings.binary io.sockets 5 | kernel make ranges sequences ; 6 | 7 | IN: port-scan 8 | 9 | : open-port? ( host port -- ? ) 10 | [ binary [ t ] with-client ] [ 2drop f ] recover ; 11 | 12 | : open-ports ( host -- seq ) 13 | 1024 [1..b] [ 14 | [ 2dup open-port? [ , ] [ drop ] if ] each drop 15 | ] { } make ; 16 | 17 | : scan-ports ( host -- ) 18 | [ "Scanning %s...\n" printf ] 19 | [ open-ports [ "%d is open\n" printf ] each ] 20 | bi ; 21 | 22 | : knock-ports ( host ports -- ) 23 | [ open-port? drop ] with each ; 24 | -------------------------------------------------------------------------------- /port-scan/summary.txt: -------------------------------------------------------------------------------- 1 | Simple port scanner 2 | -------------------------------------------------------------------------------- /power-of-2/Makefile: -------------------------------------------------------------------------------- 1 | powermake: power-of-2.c 2 | ${CC} -O3 -fno-common -c power-of-2.c 3 | ${CC} -O3 -dynamiclib -install_name power-of-2.dylib \ 4 | -o power-of-2.dylib power-of-2.o 5 | 6 | -------------------------------------------------------------------------------- /power-of-2/power-of-2.c: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | 4 | int64_t isPowerOfTwo (int64_t x) 5 | { 6 | return ((x > 0) && ((x & (x - 1)) == 0)); 7 | } 8 | 9 | -------------------------------------------------------------------------------- /printf-example/printf-example-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: printf-example tools.test ; 3 | 4 | IN: printf-example 5 | 6 | [ "" ] [ "" sprintf ] unit-test 7 | [ "asdf" ] [ "asdf" sprintf ] unit-test 8 | [ "10" ] [ 10 "%d" sprintf ] unit-test 9 | [ "-10" ] [ -10 "%d" sprintf ] unit-test 10 | [ "ff" ] [ 0xff "%x" sprintf ] unit-test 11 | [ "Hello, World!" ] [ "Hello, World!" "%s" sprintf ] unit-test 12 | [ "printf test" ] [ "printf test" sprintf ] unit-test 13 | [ "char a = 'a'" ] [ CHAR: a "char %c = 'a'" sprintf ] unit-test 14 | [ "0 message(s)" ] [ 0 "message" "%d %s(s)" sprintf ] unit-test 15 | [ "0 message(s) with %" ] [ 0 "message" "%d %s(s) with %%" sprintf ] unit-test 16 | [ "There are 10 monkeys in the kitchen" ] [ 10 "kitchen" "There are %d monkeys in the %s" sprintf ] unit-test 17 | [ "10%" ] [ 10 "%d%%" sprintf ] unit-test 18 | [ "[monkey]" ] [ "monkey" "[%s]" sprintf ] unit-test 19 | 20 | -------------------------------------------------------------------------------- /printf-example/printf-example.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: io io.streams.string kernel macros make math math.parser 5 | multiline peg.ebnf present quotations sequences strings ; 6 | 7 | IN: printf-example 8 | 9 | EBNF: parse-printf [=[ 10 | 11 | fmt-% = "%" => [[ [ "%" ] ]] 12 | fmt-c = "c" => [[ [ 1string ] ]] 13 | fmt-s = "s" => [[ [ present ] ]] 14 | fmt-d = "d" => [[ [ >integer number>string ] ]] 15 | fmt-f = "f" => [[ [ >float number>string ] ]] 16 | fmt-x = "x" => [[ [ >hex ] ]] 17 | unknown = (.)* => [[ >string throw ]] 18 | 19 | strings = fmt-c|fmt-s 20 | numbers = fmt-d|fmt-f|fmt-x 21 | 22 | formats = "%"~ (strings|numbers|fmt-%|unknown) 23 | 24 | plain-text = (!("%").)+ 25 | => [[ >string 1quotation ]] 26 | 27 | text = (formats|plain-text)* 28 | => [[ [ \ , suffix ] map ]] 29 | 30 | ]=] 31 | 32 | MACRO: printf ( format-string -- quot ) 33 | parse-printf reverse [ ] concat-as [ 34 | { } make reverse [ write ] each 35 | ] curry ; 36 | 37 | : sprintf ( format-string -- result ) 38 | [ printf ] with-string-writer ; inline 39 | -------------------------------------------------------------------------------- /pseudo-crypt/pseudo-crypt-tests.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: pseudo-crypt ranges sequences tools.test ; 5 | 6 | [ 7 | { 8 | "cJio3" "EdRc6" "qxAQ9" "TGtEC" "5ac2F" "huKqI" "KE3eL" 9 | "wXmSO" "YrVGR" "BBE4U" 10 | } 11 | ] [ 10 [1..b] [ 5 udihash ] map ] unit-test 12 | 13 | -------------------------------------------------------------------------------- /pseudo-crypt/pseudo-crypt.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel locals math math.functions sequences ; 5 | 6 | IN: pseudo-crypt 7 | 8 | CONSTANT: PRIMES 9 | { 1 41 2377 147299 9132313 566201239 35104476161 2176477521929 } 10 | 11 | CONSTANT: CHARS 12 | "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 13 | 14 | : base62 ( n -- string ) 15 | [ dup 0 > ] [ 62 /mod CHARS nth ] "" produce-as reverse nip ; 16 | 17 | :: udihash ( n chars -- string ) 18 | chars PRIMES nth n * 62 chars ^ mod base62 19 | chars CHAR: 0 pad-head ; 20 | -------------------------------------------------------------------------------- /pseudo-crypt/pseudo-crypt.py: -------------------------------------------------------------------------------- 1 | 2 | import string 3 | 4 | chars = string.digits + string.ascii_uppercase + string.ascii_lowercase 5 | primes = [1,41,2377,147299,9132313,566201239,35104476161,2176477521929] 6 | 7 | def base62(n): 8 | s = [] 9 | while n > 0: 10 | n, c = divmod(n, 62) 11 | s.append(chars[c]) 12 | return "".join(reversed(s)) 13 | 14 | def udihash(n, length=5): 15 | return "%0*s" % (length, base62((n * primes[length]) % (62 ** length))) 16 | 17 | for x in range(10): 18 | print x, udihash(x) 19 | 20 | 21 | -------------------------------------------------------------------------------- /random-names/bom-names.txt: -------------------------------------------------------------------------------- 1 | Aaron 2 | Aaron 3 | Abinadi 4 | Abinadom 5 | Abish 6 | Aha 7 | Ahah 8 | Akish 9 | Alma 10 | Alma 11 | Amaleki 12 | Amaleki 13 | Amalickiah 14 | Amaron 15 | Aminadab 16 | Aminadi 17 | Amlici 18 | Ammah 19 | Ammaron 20 | Ammon 21 | Ammon 22 | Ammoron 23 | Amnigaddah 24 | Amnor 25 | Amoron 26 | Amos 27 | Amos 28 | Amulek 29 | Amulon 30 | Antiomno 31 | Antionah 32 | Antionum 33 | Antipus 34 | Archeantus 35 | Benjamin 36 | Brother of Jared 37 | Captain Moroni 38 | Cezoram 39 | Chemish 40 | Christ 41 | Cohor 42 | Cohor 43 | Cohor 44 | Com 45 | Com 46 | Corianton 47 | Coriantor 48 | Coriantum 49 | Coriantum 50 | Coriantumr 51 | Coriantumr 52 | Coriantumr 53 | Corihor 54 | Corihor 55 | Corom 56 | Cumenihah 57 | Emer 58 | Emron 59 | Enos 60 | Esrom 61 | Ethem 62 | Ether 63 | Ezias 64 | Gadianton 65 | Gid 66 | Giddianhi 67 | Giddonah 68 | Giddonah 69 | Gideon 70 | Gidgiddonah 71 | Gidgiddoni 72 | Gilead 73 | Gilgah 74 | Gilgal 75 | Hagoth 76 | Hearthom 77 | Helam 78 | Helaman 79 | Helaman 80 | Helaman 81 | Helem 82 | Helorum 83 | Hem 84 | Heth 85 | Heth 86 | Himni 87 | Isabel 88 | Isaiah 89 | Ishmael 90 | Ishmael 91 | Jacob 92 | Jacob 93 | Jacob 94 | Jacom 95 | Jared 96 | Jared 97 | Jarom 98 | Jeneum 99 | Jeremiah 100 | Jesus Christ 101 | Jonas 102 | Jonas 103 | Joseph 104 | Josh 105 | Kib 106 | Kim 107 | Kimnor 108 | Benjamin 109 | Kish 110 | Kishkumen 111 | Korihor 112 | Kumen 113 | Kumenonhi 114 | Laban 115 | Lachoneus 116 | Lachoneus 117 | Lamah 118 | Laman 119 | Laman 120 | Laman 121 | Laman 122 | Lamoni 123 | Lehi 124 | Lehi 125 | Lehi 126 | Lehi 127 | Lehonti 128 | Lemuel 129 | Levi 130 | Lib 131 | Lib 132 | Limhah 133 | Limher 134 | Limhi 135 | Luram 136 | Mahah 137 | Manti 138 | Mathoni 139 | Mathonihah 140 | Morianton 141 | Morianton 142 | Mormon 143 | Mormon 144 | Moron 145 | Moroni 146 | Moroni 147 | Moronihah 148 | Moronihah 149 | Mosiah 150 | Mosiah 151 | Mulek 152 | Muloki 153 | Nehor 154 | Nephi 155 | Nephi 156 | Nephi 157 | Nephi 158 | Nephihah 159 | Neum 160 | Nimrah son of Akish 161 | Noah 162 | Noah 163 | Omer 164 | Omner 165 | Omni 166 | Orihah 167 | Paanchi 168 | Pachus 169 | Pacumeni 170 | Pagag 171 | Pahoran 172 | Pahoran 173 | Riplakish 174 | Sam 175 | Samuel 176 | Sariah 177 | Seantum 178 | Seezoram 179 | Seth 180 | Shared 181 | Shem 182 | Shemnon 183 | Sherem 184 | Shez 185 | Shez 186 | Shiblom 187 | Shiblom 188 | Shiblon 189 | Shiz 190 | Shule 191 | Teancum 192 | Teomner 193 | Timothy 194 | Tubaloth 195 | Zarahemla 196 | Zedekiah 197 | Zeezrom 198 | Zelph 199 | Zemnarihah 200 | Zenephi 201 | Zeniff 202 | Zenock 203 | Zenos 204 | Zerahemnah 205 | Zeram 206 | Zoram 207 | Zoram 208 | Zoram 209 | -------------------------------------------------------------------------------- /random-names/country-names.txt: -------------------------------------------------------------------------------- 1 | Afghanistan 2 | Albania 3 | Algeria 4 | Andorra 5 | Angola 6 | Antigua & Deps 7 | Argentina 8 | Armenia 9 | Australia 10 | Austria 11 | Azerbaijan 12 | Bahamas 13 | Bahrain 14 | Bangladesh 15 | Barbados 16 | Belarus 17 | Belgium 18 | Belize 19 | Benin 20 | Bhutan 21 | Bolivia 22 | Bosnia Herzegovina 23 | Botswana 24 | Brazil 25 | Brunei 26 | Bulgaria 27 | Burkina 28 | Burundi 29 | Cambodia 30 | Cameroon 31 | Canada 32 | Cape Verde 33 | Central African Republic 34 | Chad 35 | Chile 36 | China 37 | Colombia 38 | Comoros 39 | Congo 40 | Congo 41 | Costa Rica 42 | Croatia 43 | Cuba 44 | Cyprus 45 | Czech Republic 46 | Denmark 47 | Djibouti 48 | Dominica 49 | Dominican Republic 50 | East Timor 51 | Ecuador 52 | Egypt 53 | El Salvador 54 | Equatorial Guinea 55 | Eritrea 56 | Estonia 57 | Ethiopia 58 | Fiji 59 | Finland 60 | France 61 | Gabon 62 | Gambia 63 | Georgia 64 | Germany 65 | Ghana 66 | Greece 67 | Grenada 68 | Guatemala 69 | Guinea 70 | Guinea-Bissau 71 | Guyana 72 | Haiti 73 | Honduras 74 | Hungary 75 | Iceland 76 | India 77 | Indonesia 78 | Iran 79 | Iraq 80 | Ireland 81 | Israel 82 | Italy 83 | Ivory Coast 84 | Jamaica 85 | Japan 86 | Jordan 87 | Kazakhstan 88 | Kenya 89 | Kiribati 90 | Korea North 91 | Korea South 92 | Kosovo 93 | Kuwait 94 | Kyrgyzstan 95 | Laos 96 | Latvia 97 | Lebanon 98 | Lesotho 99 | Liberia 100 | Libya 101 | Liechtenstein 102 | Lithuania 103 | Luxembourg 104 | Macedonia 105 | Madagascar 106 | Malawi 107 | Malaysia 108 | Maldives 109 | Mali 110 | Malta 111 | Marshall Islands 112 | Mauritania 113 | Mauritius 114 | Mexico 115 | Micronesia 116 | Moldova 117 | Monaco 118 | Mongolia 119 | Montenegro 120 | Morocco 121 | Mozambique 122 | Myanmar 123 | Namibia 124 | Nauru 125 | Nepal 126 | Netherlands 127 | New Zealand 128 | Nicaragua 129 | Niger 130 | Nigeria 131 | Norway 132 | Oman 133 | Pakistan 134 | Palau 135 | Panama 136 | Papua New Guinea 137 | Paraguay 138 | Peru 139 | Philippines 140 | Poland 141 | Portugal 142 | Qatar 143 | Romania 144 | Russian Federation 145 | Rwanda 146 | St Kitts & Nevis 147 | St Lucia 148 | Saint Vincent & the Grenadines 149 | Samoa 150 | San Marino 151 | Sao Tome & Principe 152 | Saudi Arabia 153 | Senegal 154 | Serbia 155 | Seychelles 156 | Sierra Leone 157 | Singapore 158 | Slovakia 159 | Slovenia 160 | Solomon Islands 161 | Somalia 162 | South Africa 163 | South Sudan 164 | Spain 165 | Sri Lanka 166 | Sudan 167 | Suriname 168 | Swaziland 169 | Sweden 170 | Switzerland 171 | Syria 172 | Taiwan 173 | Tajikistan 174 | Tanzania 175 | Thailand 176 | Togo 177 | Tonga 178 | Trinidad & Tobago 179 | Tunisia 180 | Turkey 181 | Turkmenistan 182 | Tuvalu 183 | Uganda 184 | Ukraine 185 | United Arab Emirates 186 | United Kingdom 187 | United States 188 | Uruguay 189 | Uzbekistan 190 | Vanuatu 191 | Vatican City 192 | Venezuela 193 | Vietnam 194 | Yemen 195 | Zambia 196 | Zimbabwe 197 | -------------------------------------------------------------------------------- /random-names/demon-names.txt: -------------------------------------------------------------------------------- 1 | Abraxas 2 | Abbadon 3 | Agrith-Naar 4 | Aku 5 | Alastair 6 | Alastor 7 | Algaliarept 8 | Alichino 9 | Andariel 10 | Angel 11 | Anyanka 12 | Anzu 13 | Archimonde 14 | Artery 15 | Asmodeus 16 | Asura 17 | Azal 18 | Azazeal 19 | Azazel 20 | Azazel 21 | Azmodan 22 | Azura 23 | Amaimon 24 | Baal 25 | Babau 26 | Bacarra 27 | Bal'lak 28 | Balor 29 | Balrog 30 | Balthazar 31 | Baphomet 32 | Barakiel 33 | Barbariccia 34 | Barbas 35 | Bartimaeus 36 | Bat'Zul 37 | Beastie 38 | Be'lakor 39 | Bebilith 40 | Beelzebub 41 | Beleth 42 | Belfagor 43 | Belial 44 | Belphegor 45 | Belthazor 46 | Berry 47 | Betelguese 48 | Blackheart 49 | Cacodemon 50 | Cadaver 51 | Cagnazzo 52 | Calcabrina 53 | Calcifer 54 | Castor 55 | Cordelia 56 | Chernabog 57 | Cherry 58 | Ciriatto 59 | Claude 60 | Crawly 61 | Crowley 62 | Cyberdemon 63 | Cryto 64 | D'Hoffryn 65 | Dabura 66 | Draghinazzo 67 | Dante 68 | Darkseid 69 | Decarbia 70 | Delrith 71 | Demonita 72 | Devi 73 | Diablo 74 | Doviculus 75 | Doyle 76 | Dretch 77 | Dumain 78 | Duriel 79 | Errtu 80 | Etna 81 | Etrigan 82 | Faquarl 83 | Farfarello 84 | Femur 85 | Firebrand 86 | Randall 87 | Furfur 88 | Gaap 89 | Gary 90 | Glabrezu 91 | Gregor 92 | Gothmog 93 | The 94 | Halfrek 95 | Har'lakk 96 | Hastur 97 | Hellboy 98 | Hell 99 | Hezrou 100 | Hiei 101 | Him 102 | Hnikarr 103 | Hot 104 | Hex 105 | Infernal 106 | Inferno 107 | Jabor 108 | Jadis 109 | Janemba 110 | Japhrimel 111 | Jennifer 112 | Juiblex 113 | K'ril 114 | Kal'Ger 115 | DCI 116 | Khorne 117 | Kil'jaeden 118 | Kneesocks 119 | Koakuma 120 | Korrok 121 | Kronos 122 | Freddy 123 | Laharl 124 | Lamia 125 | Leviathan 126 | Libicocco 127 | Ligur 128 | Lilith 129 | Little 130 | Longhorn 131 | Lorne 132 | Loki 133 | Lucifer 134 | Mal'Ganis 135 | Malacoda 136 | Maledict 137 | Malfegor 138 | Malice 139 | Mammon 140 | Mancubus 141 | Mannoroth 142 | Marilith 143 | Masselin 144 | Meg 145 | Mehrunes 146 | Melkor 147 | Mephisto 148 | Mephisto 149 | Mephistopheles 150 | Mephisto 151 | N'zall 152 | Nadia 153 | Nalfeshnee 154 | Nanatoo 155 | Nero 156 | Neuro 157 | Newt 158 | Nouda 159 | Nurgle 160 | Oyashiro 161 | Rin 162 | Pazuzu 163 | Pennywise 164 | Psaro 165 | Quasit 166 | Queezle 167 | Qwan 168 | Qweffor 169 | Rakdos 170 | Ramuthra 171 | Red 172 | Retriever 173 | Randall 174 | Ronove 175 | Rosier 176 | Rubicante 177 | Ruby 178 | Satan 179 | Satan 180 | Sauron 181 | Scanty 182 | Scarlet 183 | Scarmiglione 184 | Scumspawn 185 | Sebastian 186 | Shax 187 | Silitha 188 | Slaanesh 189 | Sparda 190 | Spawn 191 | Spike 192 | Spine 193 | Straga 194 | Tempus 195 | Thammaron 196 | Tiamat 197 | Toby 198 | To'Kash 199 | Trigon 200 | Turok-Han 201 | Tzeentch 202 | Ungoliant 203 | Vein 204 | Vergil 205 | Violator 206 | Vrock 207 | Vulgrim 208 | Vyers 209 | Ware 210 | Wormwood 211 | Yaksha 212 | Yk'Lagor 213 | Zankou 214 | Zepar 215 | Overlord 216 | Zuul 217 | -------------------------------------------------------------------------------- /random-names/random-names.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2012 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: assocs assocs.extras fry grouping io.encodings.utf8 5 | io.files kernel make math memoize random sequences splitting ; 6 | 7 | IN: random-names 8 | 9 | MEMO: demon-names ( -- seq ) 10 | "vocab:random-names/demon-names.txt" utf8 file-lines ; 11 | 12 | MEMO: bom-names ( -- seq ) 13 | "vocab:random-names/bom-names.txt" utf8 file-lines ; 14 | 15 | MEMO: star-trek-races ( -- seq ) 16 | "vocab:random-names/star-trek-races.txt" utf8 file-lines ; 17 | 18 | MEMO: country-names ( -- seq ) 19 | "vocab:random-names/country-names.txt" utf8 file-lines ; 20 | 21 | ; 25 | 26 | : transition-table ( seq -- table ) 27 | H{ } clone swap [ transitions assoc-merge! ] each ; 28 | 29 | : next-char, ( prev index assoc -- next ) 30 | at swap [ '[ drop _ = ] assoc-filter ] when* 31 | random [ first , ] [ second ] bi ; 32 | 33 | : random-name ( table -- name ) 34 | [ 35 | f 0 [ 36 | [ pick next-char, ] [ 1 + ] bi over 37 | ] loop 3drop 38 | ] "" make ; 39 | 40 | PRIVATE> 41 | 42 | : generate-name ( seq -- name ) 43 | transition-table random-name ; 44 | 45 | : generate-names ( n seq -- names ) 46 | transition-table '[ _ random-name ] replicate ; 47 | -------------------------------------------------------------------------------- /random-string/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-name "random-string" } 4 | { deploy-ui? f } 5 | { deploy-c-types? f } 6 | { deploy-console? t } 7 | { deploy-unicode? f } 8 | { "stop-after-last-window?" t } 9 | { deploy-io 2 } 10 | { deploy-reflection 1 } 11 | { deploy-word-props? f } 12 | { deploy-math? t } 13 | { deploy-threads? t } 14 | { deploy-word-defs? f } 15 | } 16 | -------------------------------------------------------------------------------- /random-string/random-string.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: io kernel literals random ranges sequences ; 5 | 6 | IN: random-string 7 | 8 | CONSTANT: valid-chars $[ 9 | CHAR: A CHAR: Z [a..b] CHAR: a CHAR: z [a..b] append 10 | ] 11 | 12 | : random-string ( n -- string ) 13 | [ valid-chars random ] "" replicate-as ; 14 | 15 | : run-random-string ( -- ) 16 | 8 random-string print readln drop ; 17 | 18 | MAIN: run-random-string 19 | -------------------------------------------------------------------------------- /re-factor/re-factor.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: ascii assocs colors html.entities html.parser 5 | html.parser.printer http.client io io.styles json kernel memoize 6 | sequences sequences.extras splitting strings urls wrap.strings ; 7 | 8 | IN: re-factor 9 | 10 | : re-factor-url ( str -- url ) 11 | "http://re-factor.blogspot.com/" prepend ; 12 | 13 | : posts-url ( -- url ) 14 | "feeds/posts/default?alt=json&max-results=300" re-factor-url ; 15 | 16 | MEMO: all-posts ( -- posts ) 17 | posts-url http-get nip json> { "feed" "entry" } [ of ] each ; 18 | 19 | CONSTANT: post-style H{ 20 | { foreground COLOR: blue } 21 | } 22 | 23 | : posts. ( -- ) 24 | all-posts [ 25 | [ "title" of "$t" of ] [ "link" of ] bi 26 | over '[ "title" of _ = ] find nip "href" of 27 | >url post-style [ write-object ] with-style nl 28 | ] each ; 29 | 30 | : post-title. ( post -- ) 31 | { "title" "$t" } [ of ] each 32 | [ print ] [ length CHAR: - print ] bi nl ; 33 | 34 | : post-content. ( post -- ) 35 | { "content" "$t" } [ of ] each 36 | parse-html html-text html-unescape string-lines [ 37 | [ blank? not ] cut-when 38 | [ write ] [ 70 wrap-string print ] bi* 39 | ] each ; 40 | 41 | : post. ( n -- ) 42 | all-posts nth [ post-title. ] [ post-content. ] bi ; 43 | -------------------------------------------------------------------------------- /reasoning/reasoning-tests.factor: -------------------------------------------------------------------------------- 1 | USING: kernel math reasoning tools.test ; 2 | 3 | { 4 | T{ Add f 5 | T{ Mul f 6 | T{ Add f 7 | T{ Mul f 8 | T{ Var { s "x" } } 9 | T{ Const { n 0 } } } 10 | T{ Const { n 1 } } } 11 | T{ Const { n 3 } } } 12 | T{ Const { n 12 } } } 13 | } [ [ "x" 0 * 1 + 3 * 12 + ] >expr ] unit-test 14 | 15 | { 15 } [ 16 | [ "x" 0 * 1 + 3 * 12 + ] >expr simplify-value 17 | ] unit-test 18 | 19 | { t } [ [ "x" 0 * 1 + 3 * 12 + ] dup >expr expr> = ] unit-test 20 | -------------------------------------------------------------------------------- /reasoning/reasoning.factor: -------------------------------------------------------------------------------- 1 | USING: accessors combinators fry kernel literals match math 2 | prettyprint quotations sequences strings ; 3 | FROM: syntax => _ ; 4 | IN: reasoning 5 | 6 | TUPLE: Var s ; 7 | TUPLE: Const n ; 8 | TUPLE: Add x y ; 9 | TUPLE: Mul x y ; 10 | 11 | MATCH-VARS: ?x ?y ; 12 | 13 | : simplify1 ( expr -- expr' ) 14 | { 15 | { T{ Add f T{ Const f 0 } ?x } [ ?x ] } 16 | { T{ Add f ?x T{ Const f 0 } } [ ?x ] } 17 | { T{ Mul f ?x T{ Const f 1 } } [ ?x ] } 18 | { T{ Mul f T{ Const f 1 } ?x } [ ?x ] } 19 | { T{ Mul f ?x T{ Const f 0 } } [ T{ Const f 0 } ] } 20 | { T{ Mul f T{ Const f 0 } ?x } [ T{ Const f 0 } ] } 21 | { T{ Add f T{ Const f ?x } T{ Const f ?y } } [ ?x ?y + Const boa ] } 22 | { T{ Mul f T{ Const f ?x } T{ Const f ?y } } [ ?x ?y * Const boa ] } 23 | [ ] 24 | } match-cond ; 25 | 26 | : simplify ( expr -- expr' ) 27 | { 28 | { T{ Add f ?x ?y } [ ?x ?y [ simplify ] bi@ Add boa ] } 29 | { T{ Mul f ?x ?y } [ ?x ?y [ simplify ] bi@ Mul boa ] } 30 | [ ] 31 | } match-cond simplify1 ; 32 | 33 | : simplify-value ( expr -- str ) 34 | simplify { 35 | { T{ Const f ?x } [ ?x ] } 36 | [ drop "The expression could not be simplified to a Constant." ] 37 | } match-cond ; 38 | 39 | : >expr ( quot -- expr ) 40 | [ 41 | { 42 | { [ dup string? ] [ '[ _ Var boa ] ] } 43 | { [ dup integer? ] [ '[ _ Const boa ] ] } 44 | { [ dup \ + = ] [ drop [ Add boa ] ] } 45 | { [ dup \ * = ] [ drop [ Mul boa ] ] } 46 | } cond 47 | ] map concat call( -- expr ) ; 48 | 49 | : expr> ( expr -- quot ) 50 | { 51 | { [ dup Add? ] [ [ x>> ] [ y>> ] bi [ expr> ] bi@ '[ @ @ + ] ] } 52 | { [ dup Mul? ] [ [ x>> ] [ y>> ] bi [ expr> ] bi@ '[ @ @ * ] ] } 53 | { [ dup Const? ] [ n>> '[ _ ] ] } 54 | { [ dup Var? ] [ s>> '[ _ ] ] } 55 | } cond ; 56 | -------------------------------------------------------------------------------- /reference-server/reference-server.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors alien.c-types alien.data byte-arrays 3 | classes.struct io io.encodings.binary io.encodings.string 4 | io.encodings.utf8 io.servers kernel literals namespaces 5 | sequences unix.ffi unix.types ; 6 | 7 | IN: reference-server 8 | 9 | :: reference-server ( -- ) 10 | 1024 :> buffer 11 | AF_INET SOCK_STREAM 0 socket :> server 12 | sockaddr-in malloc-struct 13 | AF_INET >>family 14 | 0 >>addr 15 | 15000 htons >>port :> address 16 | 17 | server address sockaddr-in heap-size bind drop 18 | 19 | [ 20 | server 10 listen drop 21 | server address 0 socklen_t accept :> client 22 | client buffer 1024 0 recv 23 | buffer swap head-slice utf8 decode print flush 24 | client $[ "hello world\n" >byte-array ] 25 | dup length unix.ffi:write drop 26 | client close drop 27 | t 28 | ] loop 29 | 30 | server close drop ; 31 | 32 | : reference-server2 ( -- ) 33 | binary 34 | "reference-server" >>name 35 | 15000 >>insecure 36 | [ 37 | 1024 read-partial [ 38 | [ utf8 decode print flush ] with-global 39 | $[ "hello world\n" >byte-array ] io:write flush 40 | ] when* 41 | ] >>handler 42 | start-server wait-for-server ; 43 | 44 | MAIN: reference-server2 45 | -------------------------------------------------------------------------------- /repopular/repopular.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | IN: repopular 5 | 6 | USING: assocs assocs.extras http.client json kernel sequences 7 | utils ; 8 | 9 | : the-yahoo-way ( -- seq ) 10 | "http://query.yahooapis.com/v1/public/yql?q=use%20'http%3A%2F%2Fyqlblog.net%2Fsamples%2Fdata.html.cssselect.xml'%20as%20data.html.cssselect%3B%20select%20*%20from%20data.html.cssselect%20where%20url%3D%22repopular.com%22%20and%20css%3D%22div.pad%20a%22&format=json&diagnostics=true&callback=" 11 | http-get nip json> { "query" "results" "results" "a" } 12 | deep-of [ "href" of ] map 13 | [ "http://github.com" head? ] filter ; 14 | 15 | USING: accessors assocs html.parser http.client kernel 16 | sequences ; 17 | 18 | : the-other-way ( -- seq ) 19 | "http://repopular.com" http-get nip parse-html 20 | [ [ name>> "aside" = ] find drop ] 21 | [ [ name>> "aside" = ] find-last drop ] 22 | [ ] tri 23 | [ name>> "a" = ] filter 24 | [ attributes>> "href" of ] map 25 | [ "http://github.com" head? ] filter ; 26 | -------------------------------------------------------------------------------- /rgba-clock/rgba-clock.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2023 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors calendar calendar.format colors colors.contrast 5 | fonts generalizations kernel math math.bitwise timers ui.gadgets 6 | ui.gadgets.labels ui.pens.solid ; 7 | 8 | IN: rgba-clock 9 | 10 | : timestamp>rgba ( timestamp -- color/f ) 11 | timestamp>unix-time >integer 32 bits 12 | 24 2^ /mod 16 2^ /mod 8 2^ /mod 13 | [ 255 /f ] 4 napply ; 14 | 15 | > foreground<< ] 19 | [ [ ] dip interior<< ] 2bi ; 20 | 21 | PRIVATE> 22 | 23 | TUPLE: rgba-clock < label timer ; 24 | 25 | M: rgba-clock graft* 26 | [ timer>> start-timer ] [ call-next-method ] bi ; 27 | 28 | M: rgba-clock ungraft* 29 | [ timer>> stop-timer ] [ call-next-method ] bi ; 30 | 31 | : ( -- gadget ) 32 | "99:99:99" rgba-clock new-label 33 | monospace-font >>font 34 | dup '[ 35 | _ now 36 | [ timestamp>hms >>string ] 37 | [ timestamp>rgba swap update-colors ] bi 38 | ] f 1 seconds >>timer ; 39 | -------------------------------------------------------------------------------- /rock-paper-scissors/rock-paper-scissors-tests.factor: -------------------------------------------------------------------------------- 1 | USING: kernel tools.test ; 2 | 3 | IN: rock-paper-scissors 4 | 5 | { t } [ \ scissors \ paper beats? ] unit-test 6 | { f } [ \ scissors \ paper swap beats? ] unit-test 7 | { t } [ \ rock \ scissors beats? ] unit-test 8 | { f } [ \ rock \ scissors swap beats? ] unit-test 9 | { t } [ \ paper \ rock beats? ] unit-test 10 | { f } [ \ paper \ rock swap beats? ] unit-test 11 | { f } [ \ rock \ rock beats? ] unit-test 12 | { f } [ \ paper \ paper beats? ] unit-test 13 | { f } [ \ scissors \ scissors beats? ] unit-test 14 | -------------------------------------------------------------------------------- /rock-paper-scissors/rock-paper-scissors.factor: -------------------------------------------------------------------------------- 1 | USING: combinators formatting io kernel random ; 2 | FROM: multi-methods => GENERIC: METHOD: ; 3 | IN: rock-paper-scissors 4 | 5 | SINGLETONS: rock paper scissors ; 6 | 7 | GENERIC: beats? ( obj1 obj2 -- ? ) 8 | 9 | METHOD: beats? { scissors paper } 2drop t ; 10 | METHOD: beats? { rock scissors } 2drop t ; 11 | METHOD: beats? { paper rock } 2drop t ; 12 | METHOD: beats? { object object } 2drop f ; 13 | 14 | : play. ( obj1 obj2 -- ) 15 | { 16 | { [ 2dup beats? ] [ "WIN" ] } 17 | { [ 2dup = ] [ "TIE" ] } 18 | [ "LOSE" ] 19 | } cond "%s vs. %s: %s\n" printf ; 20 | 21 | : computer ( -- obj ) 22 | { rock paper scissors } random ; 23 | 24 | : rock ( -- ) \ rock computer play. ; 25 | 26 | : paper ( -- ) \ paper computer play. ; 27 | 28 | : scissors ( -- ) \ scissors computer play. ; 29 | -------------------------------------------------------------------------------- /sanitize-paths/sanitize-paths-tests.factor: -------------------------------------------------------------------------------- 1 | USING: combinators kernel sequences strings tools.test ; 2 | 3 | IN: sanitize-paths 4 | 5 | { "abcdef" } [ "abcdef" sanitize-path ] unit-test 6 | 7 | ! test special characters 8 | { t } [ 9 | "<>|/\\*?:" [ 10 | 1string { 11 | [ sanitize-path "file" = ] 12 | [ "a" prepend sanitize-path "a" = ] 13 | [ "a" append sanitize-path "a" = ] 14 | [ "a" "a" surround sanitize-path "aa" = ] 15 | } cleave and and and 16 | ] all? 17 | ] unit-test 18 | 19 | ! test unicode 20 | { "笊, ざる.pdf" } [ "笊, ざる.pdf" sanitize-path ] unit-test 21 | { "whatēverwëirduserînput" } [ 22 | " what\\ēver//wëird:user:înput:" sanitize-path ] unit-test 23 | 24 | ! test windows reserved named 25 | { t } [ 26 | { "CON" "lpt1" "com4" " aux" " LpT\x122" } 27 | [ sanitize-path "file" = ] all? 28 | ] unit-test 29 | { "COM10" } [ "COM10" sanitize-path ] unit-test 30 | 31 | ! test blanks 32 | { "file" } [ "<" sanitize-path ] unit-test 33 | 34 | ! test dots 35 | { "file.pdf" } [ ".pdf" sanitize-path ] unit-test 36 | { "file.pdf" } [ "<.pdf" sanitize-path ] unit-test 37 | { "file..pdf" } [ "..pdf" sanitize-path ] unit-test 38 | -------------------------------------------------------------------------------- /sanitize-paths/sanitize-paths.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2014 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel math sequences splitting unicode ; 5 | 6 | IN: sanitize-paths 7 | 8 | " member? ] reject ; 12 | 13 | : filter-control ( str -- str' ) 14 | [ control? ] reject ; 15 | 16 | : filter-blanks ( str -- str' ) 17 | [ blank? ] split-when harvest " " join ; 18 | 19 | : filter-windows-reserved ( str -- str' ) 20 | dup >upper { 21 | "CON" "PRN" "AUX" "NUL" "COM1" "COM2" "COM3" "COM4" 22 | "COM5" "COM6" "COM7" "COM8" "COM9" "LPT1" "LPT2" "LPT3" 23 | "LPT4" "LPT5" "LPT6" "LPT7" "LPT8" "LPT9" 24 | } member? [ drop "file" ] when ; 25 | 26 | : filter-empty ( str -- str' ) 27 | [ "file" ] when-empty ; 28 | 29 | : filter-dots ( str -- str' ) 30 | dup first CHAR: . = [ "file" prepend ] when ; 31 | 32 | PRIVATE> 33 | 34 | : sanitize-path ( path -- path' ) 35 | filter-special filter-control filter-blanks 36 | filter-windows-reserved filter-empty filter-dots 37 | 255 index-or-length head ; 38 | -------------------------------------------------------------------------------- /semver/ebnf/ebnf.factor: -------------------------------------------------------------------------------- 1 | USING: math.parser multiline peg.ebnf sequences sequences.deep ; 2 | 3 | IN: semver.ebnf 4 | 5 | EBNF: parse-semvar [=[ 6 | 7 | letter = "A" | "B" | "C" | "D" | "E" | "F" | "G" | "H" | "I" | "J" 8 | | "K" | "L" | "M" | "N" | "O" | "P" | "Q" | "R" | "S" | "T" 9 | | "U" | "V" | "W" | "X" | "Y" | "Z" | "a" | "b" | "c" | "d" 10 | | "e" | "f" | "g" | "h" | "i" | "j" | "k" | "l" | "m" | "n" 11 | | "o" | "p" | "q" | "r" | "s" | "t" | "u" | "v" | "w" | "x" 12 | | "y" | "z" 13 | 14 | positive-digit = "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" 15 | 16 | digit = "0" | positive-digit 17 | 18 | digits = ( digit digits ) | digit 19 | 20 | non-digit = letter | "-" 21 | 22 | identifier-character = digit | non-digit 23 | 24 | identifier-characters 25 | = ( identifier-character identifier-character ) 26 | | identifier-character 27 | 28 | numeric-identifier 29 | = ( positive-digit digits ) 30 | | positive-digit 31 | | "0" 32 | 33 | alphanumeric-identifier 34 | = ( identifier-character non-digit identifier-character ) 35 | | ( identifier-character non-digit ) 36 | | ( non-digit identifier-character ) 37 | | non-digit 38 | => [[ flatten ]] 39 | 40 | build-identifier = alphanumeric-identifier | digits 41 | 42 | pre-release-identifier = alphanumeric-identifier | digits 43 | 44 | dot-separated-build-identifiers 45 | = ( build-identifier "."~ dot-separated-build-identifiers ) 46 | | build-identifier 47 | 48 | build = dot-separated-build-identifiers => [[ ]] 49 | 50 | dot-separated-pre-release-identifiers 51 | = ( pre-release-identifier "."~ dot-separated-pre-release-identifiers ) 52 | | pre-release-identifier 53 | 54 | pre-release = dot-separated-pre-release-identifiers => [[ ]] 55 | 56 | patch = numeric-identifier => [[ flatten concat string>number ]] 57 | 58 | minor = numeric-identifier => [[ flatten concat string>number ]] 59 | 60 | major = numeric-identifier => [[ flatten concat string>number ]] 61 | 62 | version-core = major "."~ minor "."~ patch 63 | 64 | valid-semvar 65 | = ( version-core "-"~ pre-release "+"~ build ) 66 | | ( version-core "-"~ pre-release ) 67 | | ( version-core "+"~ build ) 68 | | version-core 69 | 70 | ]=] 71 | -------------------------------------------------------------------------------- /shortuuid/shortuuid-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel namespaces tools.test ; 3 | 4 | IN: shortuuid 5 | 6 | { "VoVuUtBhZ6TvQSAYEqNdF5" } [ 7 | t legacy? [ 8 | "12345678-1234-5678-1234-567812345678" encode-uuid 9 | ] with-variable 10 | ] unit-test 11 | 12 | { "12345678-1234-5678-1234-567812345678" } [ 13 | t legacy? [ 14 | "VoVuUtBhZ6TvQSAYEqNdF5" decode-uuid 15 | ] with-variable 16 | ] unit-test 17 | 18 | { "CXc85b4rqinB7s5J52TRYb" } 19 | [ "3b1f8b40-222c-4a6e-b77e-779d5a94e21c" encode-uuid ] unit-test 20 | 21 | { "3b1f8b40-222c-4a6e-b77e-779d5a94e21c" } 22 | [ "CXc85b4rqinB7s5J52TRYb" decode-uuid ] unit-test 23 | 24 | { t } [ 25 | "01" alphabet [ 26 | "12345678-1234-5678-1234-567812345678" 27 | dup encode-uuid decode-uuid = 28 | ] with-variable 29 | ] unit-test 30 | -------------------------------------------------------------------------------- /shortuuid/shortuuid.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: endian kernel math namespaces sequences strings uuid 5 | uuid.private ; 6 | 7 | IN: shortuuid 8 | 9 | SYMBOL: alphabet 10 | "23456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" 11 | alphabet set-global 12 | 13 | SYMBOL: legacy? ! compatible with pre-1.0.0 shortuuid 14 | 15 | GENERIC: encode-uuid ( uuid -- shortuuid ) 16 | 17 | M: integer encode-uuid 18 | [ dup 0 > ] alphabet get 19 | '[ _ [ length /mod ] [ nth ] bi ] 20 | "" produce-as nip 21 | legacy? get [ reverse ] unless ; 22 | 23 | M: string encode-uuid 24 | string>uuid encode-uuid ; 25 | 26 | GENERIC: decode-uuid ( shortuuid -- uuid ) 27 | 28 | M: string decode-uuid 29 | legacy? get [ ] when 30 | 0 alphabet get dup 31 | '[ _ index [ _ length * ] dip + ] reduce 32 | uuid>string ; 33 | -------------------------------------------------------------------------------- /slot-machine/deploy.factor: -------------------------------------------------------------------------------- 1 | USING: tools.deploy.config ; 2 | H{ 3 | { deploy-name "slot-machine" } 4 | { deploy-ui? f } 5 | { deploy-c-types? f } 6 | { deploy-console? t } 7 | { deploy-unicode? f } 8 | { "stop-after-last-window?" t } 9 | { deploy-io 3 } 10 | { deploy-reflection 6 } 11 | { deploy-word-props? f } 12 | { deploy-math? t } 13 | { deploy-threads? t } 14 | { deploy-word-defs? f } 15 | } 16 | -------------------------------------------------------------------------------- /slot-machine/slot-machine.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors arrays calendar combinators formatting grouping 3 | io kernel math random sequences threads ; 4 | 5 | IN: slot-machine 6 | 7 | CONSTANT: SYMBOLS "☀☁☂☃" 8 | 9 | : spin ( value -- value' ) 10 | SYMBOLS remove random ; 11 | 12 | : spin-delay ( n -- ) 13 | 15 * 25 + milliseconds sleep ; 14 | 15 | : spin-slots ( a b c n -- a b c ) 16 | { 17 | [ spin-delay ] 18 | [ 10 < [ [ spin ] 2dip ] when ] 19 | [ 15 < [ [ spin ] dip ] when ] 20 | [ drop spin ] 21 | } cleave ; 22 | 23 | : print-spin ( a b c -- a b c ) 24 | "\e[0;0H" write 25 | "Welcome to the Factor slot machine!" print nl 26 | " +--------+" print 27 | " | CASINO |" print 28 | " |--------| *" print 29 | 3dup " |%c |%c |%c | |\n" printf 30 | " |--------|/" print 31 | " | [_] |" print 32 | " +--------+" print flush ; 33 | 34 | : winner? ( a b c -- ) 35 | 3array all-equal? nl "You WIN!" "You LOSE!" ? print nl ; 36 | 37 | : play-slots ( -- ) 38 | "\e[0;0H\e[2J" write 39 | f f f 20 [ spin-slots print-spin ] each winner? ; 40 | 41 | : continue? ( -- ? ) 42 | "Press ENTER to play again." write flush readln ; 43 | 44 | : main-slots ( -- ) 45 | [ play-slots continue? ] loop ; 46 | 47 | MAIN: main-slots 48 | -------------------------------------------------------------------------------- /sorting/marriage/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /sorting/marriage/marriage-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: arrays kernel random sequences sorting sorting.marriage 3 | sorting.marriage.private tools.test ; 4 | 5 | IN: sorting.marriage 6 | 7 | [ f ] [ 0 0 { } find-max ] unit-test 8 | [ 0 ] [ 0 1 { 1 } find-max ] unit-test 9 | [ 0 ] [ 0 1 { 1 2 } find-max ] unit-test 10 | [ 1 ] [ 0 2 { 1 2 } find-max ] unit-test 11 | [ 0 ] [ 0 3 { 3 2 1 } find-max ] unit-test 12 | [ 1 ] [ 0 3 { 1 3 2 } find-max ] unit-test 13 | [ 2 ] [ 0 3 { 1 2 3 } find-max ] unit-test 14 | 15 | [ { } ] [ { } [ marriage-sort ] keep ] unit-test 16 | 17 | [ { 0 1 2 3 4 5 6 7 8 9 } ] 18 | [ 10 >array randomize [ marriage-sort ] keep ] unit-test 19 | 20 | [ t ] 21 | [ 22 | 100 [ random-32 ] replicate 23 | [ dup marriage-sort ] [ sort ] bi = 24 | ] unit-test 25 | 26 | [ t ] 27 | [ 28 | 1000 [ random-32 ] replicate 29 | [ dup marriage-sort ] [ sort ] bi = 30 | ] unit-test 31 | 32 | [ t ] 33 | [ 34 | 10000 [ random-32 ] replicate 35 | [ dup marriage-sort ] [ sort ] bi = 36 | ] unit-test 37 | 38 | -------------------------------------------------------------------------------- /sorting/marriage/marriage.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel locals math math.functions sequences 5 | sequences.private sorting.insertion ; 6 | 7 | IN: sorting.marriage 8 | 9 | ] from math.order (like sort) 13 | ! FIXME: Implement find-max using , each-integer? 14 | 15 | :: find-max ( from to seq -- i ) 16 | from to >= [ f ] [ 17 | from from 1 + [ dup to < ] [ 18 | 2dup [ seq nth-unsafe ] bi@ < [ nip dup ] when 1 + 19 | ] while drop 20 | ] if ; 21 | 22 | :: (marriage-sort) ( seq end skip -- seq end' ) 23 | 0 skip seq find-max 24 | skip end [ 2dup < ] [ 25 | 2over [ seq nth-unsafe ] bi@ <= 26 | [ 1 - [ seq exchange-unsafe ] 2keep ] 27 | [ [ 1 + ] dip ] if 28 | ] while nip 1 - [ seq exchange-unsafe seq ] keep ; 29 | 30 | PRIVATE> 31 | 32 | : marriage-sort ( seq -- ) 33 | dup length 34 | [ dup sqrt 1 - >fixnum dup 0 > ] 35 | [ (marriage-sort) ] while 2drop 36 | [ ] insertion-sort ; 37 | 38 | 39 | -------------------------------------------------------------------------------- /sorting/marriage/summary.txt: -------------------------------------------------------------------------------- 1 | Marriage sort. 2 | -------------------------------------------------------------------------------- /spark/spark-tests.factor: -------------------------------------------------------------------------------- 1 | USING: math math.constants math.functions sequences tools.test ; 2 | IN: spark 3 | 4 | { "█▁█▁" } [ { 1 0 1 0 } spark ] unit-test 5 | { "█▁█▁▄" } [ { 1 0 1 0 0.5 } spark ] unit-test 6 | { "█▄█▄▁" } [ { 1 0 1 0 -1 } spark ] unit-test 7 | 8 | { "▁▁▃▂█" } [ { 1 5 22 13 53 } spark ] unit-test 9 | { "▄▆▂█▁" } [ { 9 13 5 17 1 } spark ] unit-test 10 | 11 | { "▁▂▃▄▂█" } [ "0,30,55,80,33,150" spark ] unit-test 12 | { "▁▂▃▄▂█" } [ { 0 30 55 80 33 150 } spark ] unit-test 13 | { "▃▄▅▆▄█" } [ { 0 30 55 80 33 150 } -100 spark-min ] unit-test 14 | { "▁▅██▅█" } [ { 0 30 55 80 33 150 } 50 spark-max ] unit-test 15 | { "▁▁▄█▁█" } [ { 0 30 55 80 33 150 } 30 80 spark-range ] unit-test 16 | 17 | { "▄▆█▆▄▂▁▂▄" } [ 9 [ pi 4 / * sin ] map spark ] unit-test 18 | { "█▆▄▂▁▂▄▆█" } [ 9 [ pi 4 / * cos ] map spark ] unit-test 19 | -------------------------------------------------------------------------------- /spark/spark.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2014 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel locals math math.order math.parser math.statistics 5 | namespaces sequences splitting strings ; 6 | 7 | IN: spark 8 | 9 | SYMBOL: ticks 10 | "▁▂▃▄▅▆▇█" ticks set-global 11 | 12 | :: spark-range ( seq min max -- str ) 13 | max min - ticks get length 1 - / [ 1 ] when-zero :> unit 14 | seq [ min max clamp min - unit /i ticks get nth ] "" map-as ; 15 | 16 | : spark-min ( seq min -- str ) 17 | over supremum spark-range ; 18 | 19 | : spark-max ( seq max -- str ) 20 | [ dup infimum ] dip spark-range ; 21 | 22 | GENERIC: spark ( seq -- str ) 23 | 24 | M: object spark dup minmax spark-range ; 25 | 26 | M: string spark "," split [ string>number ] map spark ; 27 | -------------------------------------------------------------------------------- /square/square-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: sequences square tools.test ; 3 | 4 | [ t ] [ 5 | { 6 | { { 0 0 } { 0 1 } { 1 1 } { 1 0 } } ! standard square 7 | { { 0 0 } { 2 1 } { 3 -1 } { 1 -2 } } ! non-axis-aligned square 8 | { { 0 0 } { 1 1 } { 0 1 } { 1 0 } } ! different order 9 | { { 0 0 } { 0 4 } { 2 2 } { -2 2 } } ! rotated square 10 | } [ square? ] all? 11 | ] unit-test 12 | 13 | [ f ] [ 14 | { 15 | { { 0 0 } { 0 2 } { 3 2 } { 3 0 } } ! rectangle 16 | { { 0 0 } { 3 4 } { 8 4 } { 5 0 } } ! rhombus 17 | { { 0 0 } { 0 0 } { 1 1 } { 0 0 } } ! only 2 distinct points 18 | { { 0 0 } { 0 0 } { 1 0 } { 0 1 } } ! only 3 distinct points 19 | } [ square? ] any? 20 | ] unit-test 21 | 22 | -------------------------------------------------------------------------------- /square/square.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel math math.combinatorics math.vectors sequences 5 | sets ; 6 | 7 | IN: square 8 | 9 | : square? ( seq -- ? ) 10 | members [ length 4 = ] [ 11 | 2 [ first2 distance ] map-combinations 12 | { 0 } diff length 2 = 13 | ] bi and ; 14 | -------------------------------------------------------------------------------- /subdomains/subdomains-tests.factor: -------------------------------------------------------------------------------- 1 | USING: subdomains tools.test ; 2 | 3 | { "factorcode.org" } [ 4 | "www.mail.ftp.localhost.factorcode.org" 5 | remove-common-subdomains 6 | ] unit-test 7 | 8 | { V{ "b.c" "c.d.e" "e.f" } } [ 9 | { "a.b.c" "b.c" "c.d.e" "e.f" } 10 | remove-observed-subdomains 11 | ] unit-test 12 | 13 | { t } [ "re.factorcode.org" valid-domain? ] unit-test 14 | { f } [ "not-valid.factorcode.org" valid-domain? ] unit-test 15 | 16 | { { "a.b.c.com" "b.c.com" "c.com" } } [ 17 | "a.b.c.com" split-domain 18 | ] unit-test 19 | 20 | { "factorcode.org" } [ 21 | "a.b.c.d.factorcode.org" remove-subdomains 22 | ] unit-test 23 | { "cr.yp.to" } [ 24 | "sorting.cr.yp.to" remove-subdomains 25 | ] unit-test 26 | -------------------------------------------------------------------------------- /subdomains/subdomains.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2024 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: combinators.short-circuit dns http.download 5 | io.encodings.utf8 io.files io.files.temp kernel math.order 6 | sequences sorting splitting ; 7 | 8 | IN: subdomains 9 | 10 | MEMO: top-5000-subdomains ( -- subdomains ) 11 | "https://raw.githubusercontent.com/danielmiessler/SecLists/refs/heads/master/Discovery/DNS/subdomains-top1million-5000.txt" 12 | cache-directory download-once-into utf8 file-lines ; 13 | 14 | : remove-common-subdomains ( host -- host' ) 15 | top-5000-subdomains [ "." append ] map '[ _ [ ?head ] any? ] loop ; 16 | 17 | : remove-prefixed ( seq -- seq' ) 18 | sort V{ } clone [ 19 | dup '[ 20 | [ _ [ head? ] with none? ] _ push-when 21 | ] each 22 | ] keep ; 23 | 24 | : remove-observed-subdomains ( hosts -- hosts' ) 25 | [ "." prepend reverse ] map remove-prefixed [ reverse rest ] map ; 26 | 27 | : valid-domain? ( host -- ? ) 28 | { 29 | [ dns-A-query message>a-names empty? not ] 30 | [ dns-AAAA-query message>aaaa-names empty? not ] 31 | } 1|| ; 32 | 33 | : split-domain ( host -- hosts ) 34 | "." split dup length 1 [-] [ tail "." join ] with map ; 35 | 36 | : remove-subdomains ( host -- host' ) 37 | split-domain [ valid-domain? ] find-last nip ; 38 | -------------------------------------------------------------------------------- /ta-lib/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /ta-lib/ta-lib.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2013 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: alien.c-types alien.data kernel locals math sequences 5 | specialized-arrays ta-lib.ffi ; 6 | 7 | SPECIALIZED-ARRAY: double 8 | 9 | IN: ta-lib 10 | 11 | 19 | 20 | :: MOM ( seq n -- seq' ) 21 | 0 seq length 1 - seq double >c-array n 22 | 0 int 0 int 23 | seq length 24 | [ TA_MOM check-error ] keep ; 25 | -------------------------------------------------------------------------------- /telnet-server/telnet-server.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2012 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors kernel io io.encodings.binary io.servers 5 | io.launcher namespaces ; 6 | 7 | IN: telnet-server 8 | 9 | ! http://factor-language.blogspot.com/2008/06/https-support-in-httpserver-some-notes.html 10 | 11 | : handle-telnet-client ( -- ) 12 | 13 | "/bin/sh -i" >>command 14 | input-stream get >>stdin 15 | output-stream get >>stdout 16 | +stdout+ >>stderr 17 | run-process drop ; 18 | 19 | : ( port -- server ) 20 | binary 21 | "telnet" >>name 22 | swap >>insecure 23 | [ handle-telnet-client ] >>handler ; 24 | 25 | : start-telnet-server ( -- ) 26 | 10666 start-server wait-for-server ; 27 | 28 | MAIN: start-telnet-server 29 | 30 | -------------------------------------------------------------------------------- /ten-ten/ten-ten.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: kernel math math.functions memoize ranges sequences 5 | strings ; 6 | 7 | IN: ten-ten 8 | 9 | fixnum ] bi@ 18 | [ 3600000 * ] dip + ; 19 | 20 | : tt ( p -- tt ) 21 | [ BASE * ] keep 10 [1..b) [ 22 | [ BASE /mod ] dip * 23 | ] map nip sum BASE mod + floor ; 24 | 25 | : tt>string ( tt -- str ) 26 | 10 [ BASE /mod ALPHABET nth ] replicate 27 | nip reverse >string 28 | [ CHAR: \s 3 ] dip insert-nth 29 | [ CHAR: \s 7 ] dip insert-nth ; 30 | 31 | PRIVATE> 32 | 33 | : ten-ten ( lat lon -- tt ) 34 | p tt tt>string ; 35 | 36 | 37 | -------------------------------------------------------------------------------- /ternary-search-trees/ternary-search-tree.java: -------------------------------------------------------------------------------- 1 | public class TernaryTree 2 | { 3 | private Node m_root = null; 4 | 5 | private void Add(string s, int pos, ref Node node) 6 | { 7 | if (node == null) { node = new Node(s[pos], false); } 8 | 9 | if (s[pos] < node.m_char) { Add(s, pos, ref node.m_left); } 10 | else if (s[pos] > node.m_char) { Add(s, pos, ref node.m_right); } 11 | else 12 | { 13 | if (pos + 1 == s.Length) { node.m_wordEnd = true; } 14 | else { Add(s, pos + 1, ref node.m_center); } 15 | } 16 | } 17 | 18 | public void Add(string s) 19 | { 20 | if (s == null || s == "") throw new ArgumentException(); 21 | 22 | Add(s, 0, ref m_root); 23 | } 24 | 25 | public bool Contains(string s) 26 | { 27 | if (s == null || s == "") throw new ArgumentException(); 28 | 29 | int pos = 0; 30 | Node node = m_root; 31 | while (node != null) 32 | { 33 | int cmp = s[pos] - node.m_char; 34 | if (s[pos] < node.m_char) { node = node.m_left; } 35 | else if (s[pos] > node.m_char) { node = node.m_right; } 36 | else 37 | { 38 | if (++pos == s.Length) return node.m_wordEnd; 39 | node = node.m_center; 40 | } 41 | } 42 | 43 | return false; 44 | } 45 | } 46 | 47 | 48 | 49 | class Node 50 | { 51 | internal char m_char; 52 | internal Node m_left, m_center, m_right; 53 | internal bool m_wordEnd; 54 | 55 | public Node(char ch, bool wordEnd) 56 | { 57 | m_char = ch; 58 | m_wordEnd = wordEnd; 59 | } 60 | } 61 | 62 | 63 | -------------------------------------------------------------------------------- /ternary-search-trees/ternary-search-trees-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: assocs fry kernel sequences sorting ternary-search-trees 3 | tools.test ; 4 | 5 | IN: ternary-search-trees 6 | 7 | [ 0 ] [ assoc-size ] unit-test 8 | 9 | [ 1 ] [ 10 | 11 | "value" "key" pick set-at 12 | assoc-size 13 | ] unit-test 14 | 15 | [ 1 ] [ 16 | 17 | "value" "key" pick set-at 18 | "value" "key" pick set-at 19 | assoc-size 20 | ] unit-test 21 | 22 | [ 0 ] [ 23 | 24 | "value" "key" pick set-at 25 | "key" over delete-at 26 | "key" over delete-at 27 | assoc-size 28 | ] unit-test 29 | 30 | [ "value" 1 ] [ 31 | "value" "key" 32 | [ [ set-at ] [ at ] 2bi ] [ assoc-size ] bi 33 | ] unit-test 34 | 35 | [ { { "key" "value" } } ] [ 36 | "value" "key" [ set-at ] keep 37 | >alist 38 | ] unit-test 39 | 40 | [ { { "foo" "bar" } { "key" "value" } } ] [ 41 | 42 | "value" "key" pick set-at 43 | "bar" "foo" pick set-at 44 | >alist sort 45 | ] unit-test 46 | 47 | 48 | ! MEMO: dict-words ( -- seq ) 49 | ! "/usr/share/dict/words" ascii file-lines [ >lower ] map ; 50 | 51 | ! dict-words [ 52 | ! H{ } clone [ '[ dup _ set-at ] each ] keep 53 | ! ] time 54 | 55 | ! dict-words [ 56 | ! [ '[ dup _ set-at ] each ] keep 57 | ! ] time 58 | 59 | ! [ 1000000 H{ } clone '[ "zyx" _ at drop ] times ] time 60 | ! [ 1000000 '[ "zyx" _ at drop ] times ] time 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /ternary-search-trees/ternary-search-trees.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: accessors accessors.maybe arrays assocs combinators fry 3 | kernel make math math.order sequences strings ; 4 | 5 | IN: ternary-search-trees 6 | 7 | > 13 | 14 | : ( -- node ) 15 | tree-node new ; 16 | 17 | : (search) ( node ch -- node/f ) 18 | over ch>> [ 19 | dupd <=> swapd { 20 | { +lt+ [ lt>> dup [ swap (search) ] [ nip ] if ] } 21 | { +gt+ [ gt>> dup [ swap (search) ] [ nip ] if ] } 22 | [ drop nip ] 23 | } case [ eq>> ] [ f ] if* 24 | ] [ 2drop f ] if* ; inline recursive 25 | 26 | : search ( node key -- node/f ) 27 | [ over [ (search) ] [ drop ] if dup not ] find 2drop ; 28 | 29 | ! FIXME: don't have leaf nodes, store value in eq? 30 | 31 | : (insert) ( node ch -- node' ) 32 | over ch>> [ 33 | dupd <=> swapd { 34 | { +lt+ [ [ ] maybe-lt swap (insert) ] } 35 | { +gt+ [ [ ] maybe-gt swap (insert) ] } 36 | [ drop nip ] 37 | } case 38 | ] [ >>ch ] if* [ ] maybe-eq ; inline recursive 39 | 40 | : insert ( value key node -- ? ) 41 | swap [ (insert) ] each swap >>value 42 | [ exists>> ] [ t >>exists drop ] bi ; 43 | 44 | PRIVATE> 45 | 46 | << 47 | TUPLE: ternary-search-tree root count ; 48 | ternary-search-tree define-maybe-accessors 49 | >> 50 | 51 | : ( -- tree ) 52 | f 0 ternary-search-tree boa ; 53 | 54 | : >ternary-search-tree ( assoc -- tree ) 55 | assoc-clone-like ; 56 | 57 | M: ternary-search-tree at* 58 | root>> swap search 59 | [ [ value>> ] [ exists>> ] bi ] [ f f ] if* ; 60 | 61 | M: ternary-search-tree new-assoc 62 | 2drop ; 63 | 64 | M: ternary-search-tree clear-assoc 65 | f >>root 0 >>count drop ; 66 | 67 | M: ternary-search-tree delete-at 68 | [ root>> swap search dup [ exists>> ] [ f ] if* ] keep 69 | swap [ 70 | [ 1 - ] change-count drop 71 | f >>value f >>exists drop 72 | ] [ 2drop ] if ; 73 | 74 | M: ternary-search-tree assoc-size count>> ; 75 | 76 | M: ternary-search-tree set-at 77 | [ [ ] maybe-root insert ] keep 78 | swap [ [ 1 + ] change-count ] unless drop ; 79 | 80 | : (>alist) ( key node/f -- ) 81 | [ 82 | dup exists>> [ over over value>> 2array , ] when 83 | [ dupd lt>> (>alist) ] 84 | [ 85 | dupd 86 | [ ch>> [ 1string append ] when* ] [ eq>> ] bi 87 | (>alist) 88 | ] 89 | [ dupd gt>> (>alist) ] tri drop 90 | ] [ drop ] if* ; 91 | 92 | M: ternary-search-tree >alist 93 | "" swap root>> [ (>alist) ] { } make ; 94 | 95 | M: ternary-search-tree clone 96 | >alist >ternary-search-tree ; 97 | 98 | M: ternary-search-tree assoc-like 99 | drop dup ternary-search-tree? 100 | [ >ternary-search-tree ] unless ; 101 | 102 | INSTANCE: ternary-search-tree assoc 103 | 104 | ! FIXME: : partial-search ( str -- ) drop ; 105 | ! FIXME: : near-search ( str -- ) drop ; 106 | 107 | -------------------------------------------------------------------------------- /text-or-binary/text-or-binary-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: arrays sequences text-or-binary tools.test ; 3 | 4 | [ t ] [ "" text? ] unit-test 5 | [ f ] [ "\0" text? ] unit-test 6 | [ t ] [ "asdf" text? ] unit-test 7 | [ f ] [ "\0asdf" text? ] unit-test 8 | 9 | [ t ] [ 10 1 90 CHAR: A append text? ] unit-test 10 | [ f ] [ 20 1 80 CHAR: A append text? ] unit-test 11 | 12 | -------------------------------------------------------------------------------- /text-or-binary/text-or-binary.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: io io.encodings.binary io.files kernel math sequences ; 5 | 6 | IN: text-or-binary 7 | 8 | ] count ] [ length ] bi / 0.85 > 16 | ] if-empty ; 17 | 18 | PRIVATE> 19 | 20 | : text? ( seq -- ? ) 21 | [ includes-zeros? not ] [ majority-printable? ] bi and ; 22 | 23 | : text-file? ( path -- ? ) 24 | binary [ 1024 read text? ] with-file-reader ; 25 | 26 | : binary? ( seq -- ? ) 27 | text? not ; 28 | 29 | : binary-file? ( path -- ? ) 30 | text-file? not ; 31 | 32 | -------------------------------------------------------------------------------- /tf-idf/authors.txt: -------------------------------------------------------------------------------- 1 | John Benediktsson 2 | -------------------------------------------------------------------------------- /tf-idf/stopwords.txt: -------------------------------------------------------------------------------- 1 | de 2 | o 3 | a 4 | an 5 | com 6 | the 7 | this 8 | that 9 | with 10 | -------------------------------------------------------------------------------- /tf-idf/summary.txt: -------------------------------------------------------------------------------- 1 | Simple TF-IDF search engine. 2 | -------------------------------------------------------------------------------- /tf-idf/tf-idf-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tf-idf tools.test ; 2 | 3 | { 4 | H{ 5 | { "a" { "path1" 3 } } 6 | { "b" { "path1" 2 } } 7 | { "c" { "path1" 1 } } 8 | } 9 | } [ "path1" { "a" "a" "a" "b" "b" "c" } index1 ] unit-test 10 | 11 | { 12 | H{ 13 | { "a" V{ { "path1" 3 } { "path2" 1 } } } 14 | { "b" V{ { "path1" 2 } { "path2" 2 } } } 15 | { "c" V{ { "path1" 1 } { "path2" 1 } } } 16 | { "d" V{ { "path2" 1 } } } 17 | } 18 | } [ 19 | { 20 | { "path1" { "a" "a" "a" "b" "b" "c" } } 21 | { "path2" { "a" "b" "b" "c" "d" } } 22 | } index-all 23 | ] unit-test 24 | -------------------------------------------------------------------------------- /tf-idf/tf-idf.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: accessors arrays assocs assocs.extras 5 | combinators.short-circuit fry io.encodings.utf8 io.files kernel 6 | math math.functions math.statistics memoize sequences sets 7 | sorting splitting unicode ; 8 | 9 | IN: tf-idf 10 | 11 | ! UTILS 12 | 13 | : assoc-merge-all ( seq -- merge ) 14 | H{ } clone [ assoc-merge! ] reduce ; 15 | 16 | ! TOKENIZE 17 | 18 | : split-words ( string -- words ) 19 | [ { [ Letter? ] [ digit? ] } 1|| not ] split-when harvest ; 20 | 21 | MEMO: stopwords ( -- words ) 22 | "vocab:tf-idf/stopwords.txt" utf8 file-lines fast-set ; 23 | 24 | : tokenize ( string -- words ) 25 | >lower split-words [ stopwords in? ] reject ; 26 | 27 | ! INDEX 28 | 29 | : tokenize-files ( paths -- assoc ) 30 | [ dup utf8 file-contents tokenize ] H{ } map>assoc ; 31 | 32 | : index1 ( path words -- index ) 33 | histogram [ 2array ] with assoc-map ; 34 | 35 | : index-all ( assoc -- index ) 36 | [ index1 ] { } assoc>map assoc-merge-all ; 37 | 38 | TUPLE: db docs index ; 39 | 40 | : ( docs -- db ) 41 | dup index-all db boa ; 42 | 43 | ! TF-IDF 44 | 45 | : idf ( term db -- idf ) 46 | [ nip docs>> ] [ index>> at ] 2bi 47 | [ assoc-size 1 + ] bi@ / log ; 48 | 49 | : tf-idf ( term db -- scores ) 50 | [ index>> at ] [ idf ] 2bi '[ _ * ] assoc-map ; 51 | 52 | ! SEARCH 53 | 54 | : scores ( query db -- scores ) 55 | [ >lower split-words ] dip '[ _ tf-idf ] map assoc-merge-all ; 56 | 57 | : (normalize) ( path db -- value ) 58 | [ docs>> at ] keep '[ _ idf 2 ^ ] map-sum sqrt ; 59 | 60 | : normalize ( scores db -- scores' ) 61 | '[ sum over _ (normalize) / ] assoc-map ; 62 | 63 | : search ( query db -- scores ) 64 | [ scores ] keep normalize sort-values reverse ; 65 | 66 | ! MISC 67 | 68 | USE: io.directories 69 | USE: io.pathnames 70 | 71 | : load-db ( directory -- db ) 72 | [ directory-files ] keep '[ _ prepend-path ] map 73 | tokenize-files ; 74 | -------------------------------------------------------------------------------- /thesaurus/thesaurus.dat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/thesaurus/thesaurus.dat -------------------------------------------------------------------------------- /thesaurus/thesaurus.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors combinators destructors endian io 5 | io.encodings.binary io.files kernel locals math math.order 6 | math.vectors ranges sequences strings ; 7 | 8 | IN: thesaurus 9 | 10 | ( -- reader ) 13 | "vocab:thesaurus/thesaurus.dat" binary ; 14 | 15 | : with-thesaurus ( quot -- ) 16 | [ ] dip with-input-stream ; inline 17 | 18 | : read-int ( ptr -- n ) 19 | seek-absolute seek-input 4 read le> ; 20 | 21 | : read-string ( ptr -- string ) 22 | seek-absolute seek-input "\0" read-until drop >string ; 23 | 24 | : #words ( -- n ) 0 read-int ; 25 | 26 | : word-position ( n -- ptr ) 4 * 4 + read-int ; 27 | 28 | : nth-word ( n -- word ) word-position read-string ; 29 | 30 | :: find-word ( word -- n ) 31 | #words :> high! -1 :> low! f :> candidate! 32 | [ high low - 1 > ] [ 33 | high low + 2 /i :> probe 34 | probe nth-word candidate! 35 | candidate word <=> { 36 | { +eq+ [ probe high! probe low! ] } 37 | { +lt+ [ probe low! ] } 38 | [ drop probe high! ] 39 | } case 40 | ] while candidate word = [ high ] [ f ] if ; 41 | 42 | :: find-related ( word -- words ) 43 | word find-word [ 44 | word-position word length + 1 + :> ptr 45 | ptr read-int :> #related 46 | ptr #related [1..b] 4 v*n n+v 47 | [ read-int read-string ] map 48 | ] [ { } ] if* ; 49 | 50 | PRIVATE> 51 | 52 | : related-words ( word -- words ) 53 | [ find-related ] with-thesaurus ; 54 | -------------------------------------------------------------------------------- /time/time-docs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: help.syntax help.markup math strings time ; 5 | 6 | IN: time 7 | 8 | HELP: seconds-since-1900 9 | { $values { "seconds" integer } } 10 | { $description 11 | "Returns the number of seconds between January 1, 1900 and the " 12 | "current time." 13 | } ; 14 | 15 | HELP: time-server 16 | { $description 17 | "Starts a TIME server on 127.0.0.1:3700." 18 | } ; 19 | 20 | HELP: time-client 21 | { $values { "seconds" integer } } 22 | { $description 23 | "Retrieves the current time from a TIME server running on " 24 | "127.0.0.1:3700." 25 | } ; 26 | 27 | -------------------------------------------------------------------------------- /time/time.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | 4 | USING: arrays calendar destructors io.sockets kernel math 5 | pack sequences system ; 6 | 7 | IN: time 8 | 9 | : seconds-since-1900 ( -- n ) 10 | now 1900 0 0 time- duration>seconds >integer ; 11 | 12 | : time-server ( -- ) 13 | f 3700 [ 14 | [ 15 | [ receive nip ] keep 16 | [ seconds-since-1900 1array "I" pack ] 2dip 17 | [ send ] keep t 18 | ] loop drop 19 | ] with-disposal ; 20 | 21 | : time-client ( -- seconds ) 22 | B{ 0 } "127.0.0.1" 3700 23 | f 0 [ 24 | [ send ] [ receive drop "I" unpack first ] bi 25 | ] with-disposal ; 26 | 27 | 28 | -------------------------------------------------------------------------------- /todos/todos-docs.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: arrays assocs help.markup help.syntax io kernel todos ; 5 | 6 | IN: todos 7 | 8 | : $all-todos ( element -- ) 9 | drop "" all-todos [ 10 | [ dup 2array $vocab-subsection ] [ $list nl ] bi* 11 | ] assoc-each ; 12 | 13 | ARTICLE: "vocab-todos" "Vocabulary todos" 14 | { $all-todos } ; 15 | 16 | -------------------------------------------------------------------------------- /todos/todos.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: arrays assocs formatting io io.pathnames kernel locals 5 | sequences vocabs vocabs.loader vocabs.metadata ; 6 | 7 | IN: todos 8 | 9 | : vocab-todo-path ( vocab -- string ) 10 | vocab-dir "todo.txt" append-path ; 11 | 12 | : vocab-todo ( vocab -- todos ) 13 | dup vocab-todo-path vocab-file-lines ; 14 | 15 | : set-vocab-todo ( todos vocab -- ) 16 | dup vocab-todo-path set-vocab-file-lines ; 17 | 18 | :: add-vocab-todo ( todo vocab -- ) 19 | CHAR: \n todo member? [ "invalid" throw ] when 20 | vocab vocab-todo :> todos 21 | todo todos member? [ 22 | todos todo suffix vocab set-vocab-todo 23 | ] unless ; 24 | 25 | : todos. ( vocab -- ) 26 | vocab-todo [ print ] each ; 27 | 28 | : all-todos ( vocab -- assoc ) 29 | loaded-child-vocab-names [ dup vocab-todo 2array ] map 30 | [ second empty? ] reject ; 31 | 32 | : all-todos. ( vocab -- ) 33 | all-todos [ 34 | [ "%s:\n" printf ] [ [ "- %s\n" printf ] each ] bi* 35 | ] assoc-each ; 36 | 37 | USING: lexer namespaces strings strings.parser.private 38 | unicode vocabs.parser ; 39 | 40 | SYNTAX: TODO: 41 | lexer get [ rest-of-line ] [ next-line ] bi 42 | [ blank? ] trim-slice >string current-vocab 43 | add-vocab-todo ; 44 | -------------------------------------------------------------------------------- /utils/utils-docs.factor: -------------------------------------------------------------------------------- 1 | USING: help.markup help.syntax ; 2 | 3 | IN: utils 4 | -------------------------------------------------------------------------------- /utils/utils-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel math sequences tools.test utils ; 3 | 4 | IN: utils 5 | 6 | [ { 1 2 } ] [ 1 => 2 ] unit-test 7 | [ { "abc" "def" } ] [ "abc" => "def" ] unit-test 8 | [ { t "some value" } ] [ t => "some value" ] unit-test 9 | [ { { 1 2 } { 3 4 } } ] [ { 1 => 2 3 => 4 } ] unit-test 10 | [ H{ { 1 2 } { 3 4 } } ] [ H{ 1 => 2 3 => 4 } ] unit-test 11 | 12 | USE: math.statistics 13 | 14 | [ { { 1 3 } { "Other" 3 } } ] 15 | [ { 1 1 1 2 2 3 } histogram 1 trim-histogram ] unit-test 16 | 17 | [ "1st" ] [ 1 humanize ] unit-test 18 | [ "2nd" ] [ 2 humanize ] unit-test 19 | [ "3rd" ] [ 3 humanize ] unit-test 20 | [ "4th" ] [ 4 humanize ] unit-test 21 | [ "11th" ] [ 11 humanize ] unit-test 22 | [ "12th" ] [ 12 humanize ] unit-test 23 | [ "13th" ] [ 13 humanize ] unit-test 24 | [ "21st" ] [ 21 humanize ] unit-test 25 | -------------------------------------------------------------------------------- /utils/utils.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors arrays assocs combinators effects.parser fry 5 | generic io.pathnames kernel lexer math math.functions math.order 6 | math.parser math.private namespaces parser random sequences 7 | sorting source-files stack-checker tools.annotations words 8 | words.constant ; 9 | 10 | IN: utils 11 | 12 | SYNTAX: => 13 | unclip-last scan-object 2array suffix! ; 14 | 15 | > parent-directory ] dip 19 | ".factor" append append-path parse-file append ; 20 | 21 | PRIVATE> 22 | 23 | SYNTAX: INCLUDE: scan-token (include) ; 24 | 25 | SYNTAX: INCLUDING: ";" [ (include) ] each-token ; 26 | 27 | : trim-histogram ( assoc n -- alist ) 28 | [ sort-values reverse ] [ cut ] bi* values sum 29 | [ "Other" swap 2array suffix ] unless-zero ; 30 | 31 | : humanize ( n -- str ) 32 | dup 100 mod 11 13 between? [ "th" ] [ 33 | dup 10 mod { 34 | { 1 [ "st" ] } 35 | { 2 [ "nd" ] } 36 | { 3 [ "rd" ] } 37 | [ drop "th" ] 38 | } case 39 | ] if [ number>string ] [ append ] bi* ; 40 | 41 | << 42 | : wrap-method ( word before-quot after-quot -- ) 43 | pick reset [ surround ] 2curry annotate ; 44 | >> 45 | 46 | << 47 | SYNTAX: BEFORE: 48 | scan-word scan-word lookup-method 49 | parse-definition [ ] wrap-method ; 50 | 51 | SYNTAX: AFTER: 52 | scan-word scan-word lookup-method 53 | [ ] parse-definition wrap-method ; 54 | >> 55 | 56 | : (count-digits) ( n m -- n' ) 57 | { 58 | { [ dup 10 < ] [ drop ] } 59 | { [ dup 100 < ] [ drop 1 fixnum+fast ] } 60 | { [ dup 1000 < ] [ drop 2 fixnum+fast ] } 61 | { [ dup 1000000000000 < ] [ 62 | dup 100000000 < [ 63 | dup 1000000 < [ 64 | dup 10000 < [ 65 | drop 3 66 | ] [ 67 | 100000 >= 5 4 ? 68 | ] if 69 | ] [ 70 | 10000000 >= 7 6 ? 71 | ] if 72 | ] [ 73 | dup 10000000000 < [ 74 | 1000000000 >= 9 8 ? 75 | ] [ 76 | 100000000000 >= 10 9 ? 77 | ] if 78 | ] if fixnum+fast 79 | ] } 80 | [ [ 12 fixnum+fast ] [ 1000000000000 /i ] bi* (count-digits) ] 81 | } cond ; inline recursive 82 | 83 | GENERIC: count-digits ( m -- n ) 84 | 85 | M: fixnum count-digits 1 swap (count-digits) ; 86 | M: bignum count-digits 1 swap (count-digits) ; 87 | 88 | : count-digits2 ( num radix -- n ) 89 | [ log ] [ log ] bi* /i 1 + ; inline 90 | 91 | SYNTAX: ?: 92 | [ scan-new-word parse-definition ] with-definition 93 | dup infer define-declared ; 94 | 95 | SYNTAX: CONSTANTS: 96 | ";" [ 97 | create-word-in 98 | [ reset-generic ] 99 | [ scan-object define-constant ] bi 100 | ] each-token ; 101 | -------------------------------------------------------------------------------- /vigenere/vigenere-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test vigenere ; 2 | 3 | { "AKIJRAODRJQQSGAISQMUODMPHUMRS" } [ 4 | "This is Harshil Darji from Dharmaj." "HDarji" >vigenere 5 | ] unit-test 6 | 7 | { "THISISHARSHILDARJIFROMDHARMAJ" } [ 8 | "Akij ra Odrjqqs Gaisq muod Mphumrs." "HDarji" vigenere> 9 | ] unit-test 10 | 11 | { "QNXEPVYTWTWP" } [ "attackatdawn" "QUEENLY" >autokey ] unit-test 12 | { "ATTACKATDAWN" } [ "qnxepvytwtwp" "QUEENLY" autokey> ] unit-test 13 | -------------------------------------------------------------------------------- /vigenere/vigenere.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2023 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: ascii kernel make math sbufs sequences ; 5 | 6 | IN: vigenere 7 | 8 | CONSTANT: LETTERS "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 9 | 10 | upper :> MSG 14 | key >upper :> KEY 15 | 16 | [ 17 | 0 MSG [| ch | 18 | ch LETTERS index [| i | 19 | [ 1 + KEY length mod i ] keep 20 | KEY nth LETTERS index 21 | encrypt? [ + ] [ - ] if 22 | LETTERS length [ + ] [ mod ] bi 23 | LETTERS nth , 24 | ] when* 25 | ] each drop 26 | ] "" make ; 27 | 28 | PRIVATE> 29 | 30 | : >vigenere ( msg key -- encrypted ) t viginere ; 31 | 32 | : vigenere> ( msg key -- decrypted ) f viginere ; 33 | 34 | upper :> MSG 38 | key >upper >sbuf :> KEY 39 | 40 | [ 41 | 0 MSG [| ch | 42 | ch LETTERS index [| i | 43 | [ 1 + i ] keep 44 | KEY encrypt? [ ch suffix! ] when nth 45 | LETTERS index 46 | encrypt? [ + ] [ - ] if 47 | LETTERS length [ + ] [ mod ] bi 48 | LETTERS nth 49 | encrypt? [ KEY over suffix! drop ] unless , 50 | ] when* 51 | ] each drop 52 | ] "" make ; 53 | 54 | PRIVATE> 55 | 56 | : >autokey ( msg key -- encrypted ) t autokey ; 57 | 58 | : autokey> ( msg key -- decrypted ) f autokey ; 59 | 60 | 61 | -------------------------------------------------------------------------------- /voting/voting-tests.factor: -------------------------------------------------------------------------------- 1 | USING: tools.test ; 2 | IN: voting 3 | 4 | { 3 } [ 5 | { 6 | { 1 2 3 } { 1 3 2 } { 2 3 1 } 7 | { 3 1 2 } { 3 2 1 } { 2 3 1 } 8 | } instant-runoff 9 | ] unit-test 10 | -------------------------------------------------------------------------------- /voting/voting.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel locals math math.statistics sequences sorting ; 3 | 4 | IN: voting 5 | 6 | : count-votes ( votes -- total ) 7 | [ first ] histogram-by sort-values ; 8 | 9 | : choose-winner ( votes total -- winner/f ) 10 | last first2 rot length 2/ > [ drop f ] unless ; 11 | 12 | : remove-loser ( votes total -- newvotes ) 13 | first first swap [ remove ] with map ; 14 | 15 | : instant-runoff ( votes -- winner ) 16 | dup count-votes 2dup choose-winner 17 | [ 2nip ] [ remove-loser instant-runoff ] if* ; 18 | -------------------------------------------------------------------------------- /wavsum/truck.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mrjbq7/re-factor/d06551d4ac7a381f8e015e4ad6f43b5ff30a087a/wavsum/truck.wav -------------------------------------------------------------------------------- /wavsum/wavsum.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: alien.c-types alien.data classes.struct io 5 | io.encodings.binary io.files math specialized-arrays ; 6 | FROM: sequences => map-sum ; 7 | 8 | IN: wavsum 9 | 10 | PACKED-STRUCT: header 11 | { id char[4] } 12 | { totallength int } 13 | { wavefmt char[8] } 14 | { format int } 15 | { pcm short } 16 | { channels short } 17 | { frequency int } 18 | { bytes_per_second int } 19 | { bytes_by_capture short } 20 | { bits_per_sample short } 21 | { data char[4] } 22 | { bytes_in_data int } ; 23 | 24 | SPECIALIZED-ARRAY: short 25 | 26 | : sum-contents ( -- sum ) 27 | read-contents short cast-array [ abs ] map-sum ; 28 | 29 | : wavsum ( path -- header sum ) 30 | binary [ header read-struct sum-contents ] with-file-reader ; 31 | -------------------------------------------------------------------------------- /wavsum/wavsum.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | from struct import calcsize, unpack 3 | from sys import argv, exit 4 | 5 | def word_iter(f): 6 | while True: 7 | _bytes = f.read(2) 8 | 9 | if len(_bytes) != 2: 10 | raise StopIteration 11 | 12 | yield unpack("=h", _bytes)[0] 13 | 14 | try: 15 | with open(argv[1], "rb") as f: 16 | wav = "=4ci8cihhiihh4ci" 17 | wav_size = calcsize(wav) 18 | metadata = unpack(wav, f.read(wav_size)) 19 | 20 | if "".join(metadata[:4]) != "RIFF": 21 | print "error: not wav file." 22 | exit(1) 23 | 24 | print sum(abs(word) for word in word_iter(f)) 25 | except IOError: 26 | print "error: can't open input file '%s'." % argv[1] 27 | exit(1) 28 | -------------------------------------------------------------------------------- /wavsum/wavsum.rb: -------------------------------------------------------------------------------- 1 | data = ARGF.read 2 | keys = %w[id totallength wavefmt format 3 | pcm channels frequency bytes_per_second 4 | bytes_by_capture bits_per_sample 5 | data bytes_in_data sum 6 | ] 7 | values = data.unpack 'Z4 i Z8 i s s i i s s Z4 i s*' 8 | sum = values.drop(12).map(&:abs).inject(:+) 9 | keys.zip(values.take(12) << sum) {|k, v| 10 | puts "#{k.ljust 17}: #{v}" 11 | } 12 | -------------------------------------------------------------------------------- /wordcount/wordcount.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2009 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: accessors ascii assocs combinators.short-circuit 5 | formatting fry io io.directories io.encodings.ascii io.files 6 | io.files.info kernel sequences sorting splitting ; 7 | 8 | IN: wordcount 9 | 10 | : \w? ( ch -- ? ) 11 | { [ Letter? ] [ digit? ] [ CHAR: _ = ] } 1|| ; inline 12 | 13 | : split-words ( seq -- seq' ) 14 | [ \w? not ] split-when harvest ; 15 | 16 | : count-words ( path -- assoc ) 17 | f H{ } clone [ 18 | '[ 19 | dup regular-file? [ 20 | name>> ascii file-contents >lower 21 | split-words [ _ inc-at ] each 22 | ] [ drop ] if 23 | ] each-directory-entry 24 | ] keep ; 25 | 26 | : print-words ( alist -- ) 27 | [ "%s\t%d\n" printf ] assoc-each ; 28 | 29 | : write-count ( assoc -- ) 30 | [ 31 | "Writing counts in decreasing order" write nl 32 | [ "/tmp/counts-decreasing-factor" ascii ] dip 33 | '[ _ sort-values reverse print-words ] with-file-writer 34 | ] [ 35 | "Writing counts in alphabetical order" write nl 36 | [ "/tmp/counts-alphabetical-factor" ascii ] dip 37 | '[ _ sort-keys print-words ] with-file-writer 38 | ] bi ; 39 | 40 | ! http://blogs.sourceallies.com/2009/12/word-counts-example-in-ruby-and-scala/ 41 | ! http://www.bestinclass.dk/index.php/2009/12/clojure-vs-ruby-scala-transient-newsgroups/ 42 | -------------------------------------------------------------------------------- /wordcount/wordcount.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | 3 | import os 4 | import re 5 | import time 6 | from collections import defaultdict 7 | from operator import itemgetter 8 | 9 | root = '/tmp/20_newsgroups' 10 | #root = '/tmp/mini_newsgroups' 11 | 12 | t0 = time.time() 13 | 14 | counts = defaultdict(int) 15 | 16 | for dirpath, dirname, filenames in os.walk(root): 17 | for filename in filenames: 18 | f = open(os.path.join(dirpath, filename)) 19 | for word in re.findall('\w+', f.read()): 20 | counts[word.lower()] += 1 21 | f.close() 22 | 23 | print "Writing counts in decreasing order" 24 | f = open('counts-decreasing-python', 'w') 25 | for k, v in sorted(counts.items(), key=itemgetter(1), reverse=True): 26 | print >> f, '%s\t%d' % (k, v) 27 | f.close() 28 | 29 | print "Writing counts in decreasing order" 30 | f = open('counts-alphabetical-python', 'w') 31 | for k, v in sorted(counts.items(), key=itemgetter(0)): 32 | print >> f, '%s\t%d' % (k, v) 33 | f.close() 34 | 35 | print 'Finished in %s seconds' % (time.time() - t0) 36 | 37 | -------------------------------------------------------------------------------- /wordcount/wordcount.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | 3 | #Change rootDir to the location of your newsgroup files 4 | rootDir = "/tmp/20_newsgroups" 5 | #rootDir = "/tmp/mini_newsgroups" 6 | raise rootDir + " does not exist" unless File.directory? rootDir 7 | 8 | #Iterates over all files under rootDir, opens each one and passes it to the block 9 | def files(rootDir) 10 | Dir.foreach(rootDir) do |dir| 11 | if dir != "." && dir != ".." 12 | puts "Processing " + dir 13 | Dir.foreach(rootDir + "/" + dir) do |file| 14 | if file != "." && file != ".." 15 | open(rootDir + "/" + dir + "/" + file) do |f| 16 | yield(f) 17 | end 18 | end 19 | end 20 | end 21 | end 22 | end 23 | 24 | t1 = Time.now 25 | counts = Hash.new(0) #0 will be the default value for non-existent keys 26 | files(rootDir) do |file| 27 | file.read.scan(/\w+/) { |word| counts[word.downcase] += 1 } 28 | end 29 | 30 | puts "Writing counts in decreasing order" 31 | open("counts-descreasing-ruby", "w") do |out| 32 | counts.sort { |a, b| b[1] <=> a[1] }.each { |pair| out << "#{pair[0]}\t#{pair[1]}\n" } 33 | end 34 | 35 | puts "Writing counts in alphabetical order" 36 | open("counts-alphabetical-ruby", "w") do |out| 37 | counts.sort { |a, b| a[0] <=> b[0] }.each { |pair| out << "#{pair[0]}\t#{pair[1]}\n" } 38 | end 39 | 40 | t2 = Time.now 41 | puts "Finished in " + (t2 - t1).to_s + " seconds" 42 | 43 | -------------------------------------------------------------------------------- /wordgen/wordgen-tests.factor: -------------------------------------------------------------------------------- 1 | 2 | USING: kernel tools.test wordgen ; 3 | 4 | IN: wordgen.tests 5 | 6 | [ 7 | H{ 8 | { "great" H{ { "you" 1 } } } 9 | { "it's" H{ { "great" 1 } } } 10 | { "you" H{ { "know" 2 } } } 11 | { "know" H{ { "it's" 1 } { "you" 1 } } } 12 | } 13 | ] 14 | [ 15 | H{ } clone "you know it's great you know" 16 | word-list word-frequency 17 | ] unit-test 18 | 19 | -------------------------------------------------------------------------------- /wordgen/wordgen.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2009 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: assocs arrays fry hashtables kernel io 5 | io.encodings.ascii io.files make math random sequences 6 | splitting vectors ; 7 | 8 | IN: wordgen 9 | 10 | : split-words ( -- seq ) 11 | [ [ "\r\n\t.,\" " split % ] each-line ] { } make harvest ; 12 | 13 | : word-pairs ( seq -- seq ) 14 | dup 1 head-slice append 15 | dup rest-slice zip ; 16 | 17 | : word-map ( seq -- assoc ) 18 | word-pairs H{ } clone 19 | [ '[ [ second ] [ first ] bi _ push-at ] each ] keep ; 20 | 21 | : next-word ( word assoc -- word' ) 22 | at random ; 23 | 24 | : wordgen-from ( start n -- str ) 25 | [ [ 1vector ] keep split-words word-map ] dip 26 | [ [ next-word dup pick push ] keep ] times 27 | 2drop " " join ; 28 | 29 | : wordgen ( n -- str ) 30 | "the" swap wordgen-from ; 31 | 32 | -------------------------------------------------------------------------------- /worldcup/worldcup.factor: -------------------------------------------------------------------------------- 1 | USING: accessors assocs classes.tuple colors formatting 2 | http.client io io.styles json kernel locals math.parser 3 | sequences ; 4 | 5 | IN: worldcup 6 | 7 | TUPLE: game home_team home_team_events home_team_tbd 8 | away_team away_team_events away_team_tbd winner match_number 9 | datetime location status ; 10 | 11 | : worldcup ( -- games ) 12 | "http://worldcup.sfg.io/matches" http-get nip json> 13 | [ game from-slots ] map ; 14 | 15 | : completed-games ( games -- games' ) 16 | [ status>> "completed" = ] filter ; 17 | 18 | CONSTANT: winner-style H{ 19 | { foreground COLOR: MediumSeaGreen } 20 | { font-style bold } 21 | } 22 | 23 | : game. ( game -- ) 24 | [let 25 | [ home_team>> ] [ away_team>> ] [ winner>> ] tri 26 | :> ( home away winner ) 27 | 28 | home "country" of dup winner = 29 | [ winner-style format ] [ write ] if bl 30 | home "goals" of number>string write 31 | 32 | " x " write 33 | 34 | away "country" of dup winner = 35 | [ winner-style format ] [ write ] if bl 36 | away "goals" of number>string write nl 37 | ] ; 38 | 39 | : worldcup. ( -- ) 40 | worldcup completed-games [ game. ] each ; 41 | -------------------------------------------------------------------------------- /wp/wp.factor: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env factor 2 | ! Copyright (C) 2008 John Benediktsson 3 | ! See http://factorcode.org/license.txt for BSD license 4 | 5 | USING: assocs io math.parser math.statistics sequences splitting 6 | sorting unicode ; 7 | 8 | IN: wp 9 | 10 | : count-words ( -- assoc ) 11 | read-contents [ blank? ] split-when harvest histogram ; 12 | 13 | : print-results ( seq -- ) 14 | [ number>string " " glue print ] assoc-each ; 15 | 16 | : wp ( -- ) 17 | count-words sort-values reverse print-results ; 18 | 19 | MAIN: wp 20 | 21 | -------------------------------------------------------------------------------- /xmode/code2pdf/code2pdf.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2010 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: kernel io.encodings.utf8 io.files pdf.layout pdf.streams 5 | sequences xmode.highlight ; 6 | 7 | IN: xmode.code2pdf 8 | 9 | : code-to-pdf ( path -- ) 10 | [ [ highlight. ] with-pdf-writer pdf>string ] 11 | [ ".pdf" append utf8 set-file-contents ] bi ; 12 | 13 | -------------------------------------------------------------------------------- /yahoo/finance/finance.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2011 John Benediktsson 2 | ! See http://factorcode.org/license.txt for BSD license 3 | 4 | USING: csv http.client kernel sequences strings urls ; 5 | 6 | IN: yahoo.finance 7 | 8 | : historical-prices ( symbol -- csv ) 9 | "http://ichart.finance.yahoo.com/table.csv" >url 10 | swap "s" set-query-param 11 | "0" "a" set-query-param 12 | "1" "b" set-query-param 13 | "2009" "c" set-query-param 14 | http-get nip string>csv ; 15 | 16 | : quotes ( symbols -- csv ) 17 | "http://finance.yahoo.com/d/quotes.csv" >url 18 | swap "+" join "s" set-query-param 19 | "sbal1v" "f" set-query-param 20 | http-get nip >string string>csv 21 | { "Symbol" "Bid" "Ask" "Last" "Volume" } prefix ; 22 | --------------------------------------------------------------------------------