├── README.md ├── blog-maker └── blog-maker.factor ├── chess └── chess.factor ├── emacskeys └── emacskeys.factor ├── examples ├── alien │ ├── assembler │ │ └── assembler.factor │ ├── callbacks │ │ └── callbacks.factor │ └── structs │ │ └── structs.factor ├── bugs │ ├── bug1021 │ │ └── bug1021.factor │ ├── bug1130 │ │ ├── bug1130.factor │ │ └── platforms.txt │ ├── bug1187 │ │ └── bug1187.factor │ ├── bug1339 │ │ └── bug1339.factor │ ├── bug1507 │ │ └── bug1507.factor │ ├── bug1559 │ │ ├── README.txt │ │ └── bug1559.factor │ ├── bug1571 │ │ └── bug1571.factor │ ├── bug677 │ │ └── bug677.factor │ ├── bug789 │ │ └── bug789.factor │ └── bug839 │ │ └── bug839.factor ├── compiler │ └── tree-builder │ │ ├── tree-builder-tests.factor │ │ └── tree-builder.factor ├── deploy │ ├── mini │ │ ├── authors.txt │ │ ├── features │ │ │ └── features.factor │ │ ├── generics │ │ │ ├── generics-tests.factor │ │ │ └── generics.factor │ │ ├── globals │ │ │ └── globals.factor │ │ ├── mini.factor │ │ ├── tests │ │ │ ├── maybe.image │ │ │ ├── test01 │ │ │ │ └── test01.factor │ │ │ ├── test02 │ │ │ │ └── test02.factor │ │ │ ├── test03 │ │ │ │ └── test03.factor │ │ │ ├── test04 │ │ │ │ └── test04.factor │ │ │ ├── test05 │ │ │ │ └── test05.factor │ │ │ ├── test06 │ │ │ │ └── test06.factor │ │ │ ├── test07 │ │ │ │ └── test07.factor │ │ │ └── test08 │ │ │ │ └── test08.factor │ │ ├── utils │ │ │ └── utils.factor │ │ └── word-stripping │ │ │ └── word-stripping.factor │ └── small │ │ └── small.factor ├── files │ └── tail │ │ └── tail.factor ├── functors │ └── functors.factor ├── golf │ ├── all-roads │ │ └── all-roads.factor │ ├── challenge-252 │ │ ├── challenge-252-tests.factor │ │ └── challenge-252.factor │ └── wordcheck │ │ ├── bits.dat │ │ ├── wordcheck-build.factor │ │ ├── wordcheck.factor │ │ └── words.dat ├── images │ ├── drawing │ │ └── drawing.factor │ └── resizing │ │ └── resizing.factor ├── lpath │ ├── agraph │ └── lpath.factor ├── math │ ├── matrices │ │ └── matrices.factor │ └── ops │ │ └── ops.factor ├── multiline │ └── multiline.factor ├── python │ └── mutagen │ │ ├── mutagen-test.py │ │ └── mutagen.factor ├── sequences │ └── sequences.factor ├── sockets │ ├── rawhttp │ │ └── rawhttp.factor │ └── resolving │ │ └── resolving.factor ├── syntax │ └── tuples │ │ └── tuples.factor ├── threads │ ├── greeters │ │ └── greeters.factor │ └── threads.factor ├── transforms │ └── transforms.factor ├── trees │ └── trees.factor ├── ui │ ├── editor │ │ └── editor.factor │ ├── gtk │ │ ├── hello │ │ │ └── hello.factor │ │ └── input │ │ │ └── input.factor │ ├── modal-dialog │ │ └── modal-dialog.factor │ ├── tail-editor │ │ └── tail-editor.factor │ └── update-editor │ │ └── update-editor.factor ├── web │ ├── chloe-template │ │ ├── chloe-template.factor │ │ └── index.xml │ ├── chloe-tostring │ │ ├── chloe-tostring.factor │ │ └── tostring.xml │ └── redirect │ │ └── redirect.factor └── yosefk │ └── yosefk.factor ├── gmane ├── adstrip │ └── adstrip.factor ├── console │ └── console.factor ├── db │ └── db.factor ├── formatting │ └── formatting.factor ├── fts │ ├── console │ │ └── console.factor │ └── fts.factor ├── html2text │ ├── html2text.factor │ ├── paragraphs │ │ └── paragraphs.factor │ └── tagpath │ │ └── tagpath.factor ├── scraper │ └── scraper.factor └── statistics │ └── statistics.factor ├── http-sync ├── http-sync.factor └── tests │ ├── ap.factor │ ├── csvstorage │ └── csvstorage.factor │ ├── hn2.factor │ └── utils │ └── utils.factor └── xkcd1313 ├── xkcd1313-tests.factor └── xkcd1313.factor /README.md: -------------------------------------------------------------------------------- 1 | playground-factor 2 | ================= 3 | This repo contains lots of work in progress code for my 4 | [Factor](http://factorcode.org/) projects. 5 | 6 | Some useful(?) Factor related wiki pages I've written: 7 | 8 | * [Parsing Gmane with Factor](https://github.com/bjourne/playground-factor/wiki/Parsing-gmane-with-factor): a Factor tutorial 9 | * [Tips & Tricks](https://github.com/bjourne/playground-factor/wiki/Tips-and-tricks): Factor idioms and small recipes 10 | * [gc notes](https://github.com/bjourne/playground-factor/wiki/gc-notes): Random notes about Factors garbage collection system 11 | * [Bootstrapping Explained](https://github.com/bjourne/playground-factor/wiki/Bootstrapping-Explained): WIP walkthrough of the bootstrap process 12 | -------------------------------------------------------------------------------- /blog-maker/blog-maker.factor: -------------------------------------------------------------------------------- 1 | ! To use this script, you need the following: 2 | ! 3 | ! * A directory containing: 4 | ! * a template.html file 5 | ! * a posts/ directory with all your markdown blog posts 6 | ! * a chrome/ directory containing stylesheets and images 7 | ! * The github version of python-markdown installed 8 | ! 9 | ! If you have all that, then you can run this script: 10 | ! 11 | ! "path/to/dir" generate-blog 12 | ! 13 | ! and hope for the best. :) 14 | USING: accessors assocs arrays combinators continuations 15 | formatting fry html.templates html.templates.fhtml io io.directories 16 | io.encodings.utf8 io.files io.launcher io.pathnames 17 | io.streams.string kernel math math.statistics namespaces sequences 18 | sequences.generalizations slots.syntax sorting splitting ; 19 | IN: blog-maker 20 | 21 | ! Configuration 22 | CONSTANT: blog-base "/blog/" 23 | CONSTANT: blog-title "Bjourne's blog" 24 | CONSTANT: scp-path "bjourne@31.192.226.186:/opt/sites/bjornlindqvist.se/www/blog" 25 | 26 | ! Utilities 27 | : directory-files-w/path ( dir -- abs-paths ) 28 | dup directory-files [ append-path absolute-path ] with map ; 29 | 30 | : read-process-contents ( cmd encoding -- str ) 31 | [ contents ] with-process-reader ; 32 | 33 | : set-file-contents-safe ( contents path encoding -- ) 34 | over parent-directory make-directories set-file-contents ; 35 | 36 | : tag-wrap2 ( body tag attrs -- str ) 37 | [ "%s=\"%s\"" sprintf ] { } assoc>map " " join rot pick 38 | "<%s %s>%s" sprintf ; 39 | 40 | : tag-wrap ( body tag -- str ) 41 | { } tag-wrap2 ; 42 | 43 | : fhtml>string ( template -- str ) 44 | [ call-template ] with-string-writer ; 45 | 46 | : link ( url title -- str ) 47 | "%s" sprintf ; 48 | 49 | ! Making blog posts 50 | TUPLE: post title date tags html slug ; 51 | 52 | CONSTANT: markdown-cmd "python -m markdown -x markdown.extensions.codehilite -x meta %s" 53 | 54 | : markdown-render ( file -- str ) 55 | markdown-cmd sprintf utf8 read-process-contents ; 56 | 57 | : markdown-metadata ( path -- assoc ) 58 | utf8 file-lines [ "" = ] split1-when drop [ ": " split1 2array ] map ; 59 | 60 | : parse-metadata ( metadata -- title date tags ) 61 | [ "title" of ] [ "date" of ] [ "tags" of " " split ] tri ; 62 | 63 | : post-month ( post -- seq ) 64 | date>> "-" split but-last ; 65 | 66 | : post-year ( post -- seq ) 67 | post-month 1 head ; 68 | 69 | : post>path-components ( post -- components ) 70 | [ post-month ] keep slug>> suffix ; 71 | 72 | : post-url ( post -- url ) 73 | post>path-components "/" join blog-base prepend ; 74 | 75 | : post>a ( post -- str ) 76 | [ post-url ] [ title>> ] bi link ; 77 | 78 | : posts>ul ( posts -- str ) 79 | [ post>a "li" tag-wrap ] map concat 80 | "ul" { { "class" "square" } } tag-wrap2 ; 81 | 82 | : post-header ( post -- header ) 83 | [ post>a "h2" tag-wrap ] 84 | [ 85 | get[ date tags ] " " join 2array { "Posted:" "Tags:" } 86 | [ [ "dd" tag-wrap ] [ "dt" tag-wrap ] bi* prepend ] 2map 87 | concat "dl" tag-wrap 88 | ] bi append ; 89 | 90 | : ( path -- post ) 91 | [ markdown-metadata parse-metadata ] 92 | [ markdown-render ] 93 | [ file-stem ] tri post boa 94 | dup [ html>> ] keep post-header prepend >>html ; 95 | 96 | : read-posts ( dir -- posts ) 97 | directory-files-w/path [ ] map ; 98 | 99 | ! Then from posts we make pages 100 | TUPLE: page title html path ; 101 | 102 | : post>page ( post -- page ) 103 | [ title>> ] 104 | [ html>> ] 105 | [ post>path-components ] tri page boa ; 106 | 107 | CONSTANT: month-title "%d post(s) for the month %04s-%02s" 108 | 109 | : month-render-title ( year/month posts -- html ) 110 | length swap first2 month-title sprintf ; 111 | 112 | : month-render-html ( year/month posts -- html ) 113 | [ month-render-title "h2" tag-wrap ] [ posts>ul ] bi append ; 114 | 115 | : month-page ( year/month posts -- page ) 116 | [ month-render-title ] 117 | [ month-render-html ] 118 | [ drop "index" suffix ] 2tri page boa ; 119 | 120 | : posts>month-pages ( posts -- assoc ) 121 | [ post-month ] collect-by [ month-page ] { } assoc>map ; 122 | 123 | CONSTANT: year-title "%d post(s) for the year %04s" 124 | 125 | : year-render-title ( year posts -- html ) 126 | length swap first year-title sprintf ; 127 | 128 | : year-render-html ( year posts -- page ) 129 | [ year-render-title "h2" tag-wrap ] [ posts>ul ] bi append ; 130 | 131 | : year-page ( year posts -- page ) 132 | [ year-render-title ] 133 | [ year-render-html ] 134 | [ drop "index" suffix ] 2tri page boa ; 135 | 136 | : posts>year-pages ( posts -- pages ) 137 | [ post-year ] collect-by [ year-page ] { } assoc>map ; 138 | 139 | ! Make index page 140 | : posts>index-page ( posts -- page ) 141 | [ date>> ] sort-with reverse 142 | [ html>> ] map "
" join blog-title swap { "index" } page boa ; 143 | 144 | ! Glueing it all together 145 | : make-pages ( dir -- pages ) 146 | read-posts { 147 | [ posts>year-pages ] 148 | [ posts>month-pages ] 149 | [ [ post>page ] map ] 150 | [ posts>index-page 1array ] 151 | } cleave 4 nappend ; 152 | 153 | ! Then with the page tuples, we generate ready html pages using fhtml 154 | ! templates. 155 | SYMBOL: page-var 156 | 157 | ! Utilities to be called from the template 158 | : stylesheet. ( str -- ) 159 | "" printf ; 160 | 161 | : adjusted-page-path ( page -- path ) 162 | [ title>> ] [ 163 | path>> "home" prefix dup last "index" = [ but-last ] when 164 | ] bi dup length 4 = [ but-last swap suffix ] [ nip ] if ; 165 | 166 | : breadcrumb. ( page -- ) 167 | adjusted-page-path dup length 168 | { 169 | { 1 { "" } } 170 | { 2 { ".." "" } } 171 | { 3 { "../.." ".." "" } } 172 | { 4 { "../.." ".." "." "" } } 173 | } at swap [ link ] 2map " » " join print ; 174 | 175 | : title. ( page -- ) 176 | [ title>> ] [ path>> ] bi length 1 > [ blog-title " - " glue ] when print ; 177 | 178 | : write-page ( page dir -- ) 179 | over path>> "/" join append-path 180 | [ page-var set "template.html" fhtml>string ] dip 181 | utf8 set-file-contents-safe ; 182 | 183 | : write-pages ( pages dir -- ) 184 | '[ _ write-page ] each ; 185 | 186 | : generate-blog ( dir -- ) 187 | [ 188 | [ "build" delete-directory ] ignore-errors 189 | "posts" make-pages "build" write-pages 190 | "chrome" "build/chrome" copy-tree 191 | "build" [ 192 | { "sh" "-c" } scp-path "scp -r * %s" sprintf suffix try-process 193 | ] with-directory 194 | ] with-directory ; 195 | -------------------------------------------------------------------------------- /chess/chess.factor: -------------------------------------------------------------------------------- 1 | USING: arrays assocs formatting grouping io kernel math math.ranges 2 | sequences sequences.repeating splitting strings ; 3 | IN: chess 4 | : initialize ( -- assoc ) 5 | 1 8 [a,b] CHAR: a CHAR: h [a,b] [ 6 | [ 48 + ] dip 2array >string ] cartesian-map concat 7 | "RWNWBWQWKWBWNWRWPWPWPWPWPWPWPWPW" "PBPBPBPBPBPBPBPBRBNBBBQBKBBBNBRB" 8 | [ 2 group ] bi@ { f } 32 cycle glue zip ; 9 | : display ( assoc -- ) 10 | values 8 group [ 11 | 1 + " %d " sprintf [ [ dup "- " ? ] map " " join ] dip dup surround 12 | ] map-index reverse 13 | " a b c d e f g h" [ prefix ] keep suffix 14 | "\n" join print flush ; 15 | : pair-at ( assoc pos -- pair/f ) 16 | dup swapd ?of [ 2array ] [ 2drop f ] if ; 17 | : extract-keys* ( assoc keys -- assoc' ) 18 | [ pair-at ] with map harvest ; 19 | : swap-squares ( f t -- move ) 20 | [ first2 ] bi@ drop f -rot swap [ 2array ] 2bi@ 2array ; 21 | : capture-text ( f t -- msg ) 22 | [ second ] bi@ 2dup and [ " x " glue ] [ 2drop "" ] if ; 23 | : move ( assoc fromto -- assoc' msg ) 24 | dupd extract-keys* dup [ length 2 = ] [ first last ] bi and [ 25 | first2 [ swap-squares assoc-union ] [ capture-text ] 2bi 26 | ] [ drop "Invalid move" ] if ; 27 | : game ( -- ? ) 28 | initialize [ 29 | dup display "Move" print readln " " split move print flush 30 | ] follow ; 31 | -------------------------------------------------------------------------------- /emacskeys/emacskeys.factor: -------------------------------------------------------------------------------- 1 | USING: accessors arrays formatting io kernel random sequences ; 2 | IN: emacskeys 3 | 4 | TUPLE: area name shortcuts ; 5 | TUPLE: shortcut key desc ; 6 | 7 | CONSTANT: shortcut-areas 8 | { 9 | T{ area 10 | { name "dired" } 11 | { shortcuts 12 | { 13 | T{ shortcut 14 | { key "D" } 15 | { desc "delete file at point" } 16 | } 17 | T{ shortcut 18 | { key "^" } 19 | { desc "visit the parent directory" } 20 | } 21 | T{ shortcut 22 | { key "+" } 23 | { desc "create directory" } 24 | } 25 | } 26 | } 27 | } 28 | T{ area 29 | { name "emacs-lisp-mode" } 30 | { shortcuts 31 | { 32 | T{ shortcut 33 | { key "C-x C-e" } 34 | { desc "evaluate the emacs lisp expression before point" } 35 | } 36 | } 37 | } 38 | } 39 | T{ area 40 | { name "comint-mode" } 41 | { shortcuts 42 | T{ shortcut 43 | { key "C-c C-l" } 44 | { desc "list all history items for the current buffer" } 45 | } 46 | } 47 | } 48 | T{ area 49 | { name "fuel-listener-mode" } 50 | { shortcuts 51 | T{ shortcut 52 | { key "C-c C-w" } 53 | { desc "open the manual for symbol at point" } 54 | } 55 | } 56 | } 57 | T{ area 58 | { name "fuel-mode" } 59 | { shortcuts 60 | { 61 | T{ shortcut 62 | { key "C-c C-d d" } 63 | { desc "open the manual for symbol at point" } 64 | } 65 | T{ shortcut 66 | { key "C-c C-d C-e" } 67 | { desc "show stack effect for word at point" } 68 | } 69 | T{ shortcut 70 | { key "C-c C-d v" } 71 | { desc "show all words in vocab" } 72 | } 73 | T{ shortcut 74 | { key "M-." } 75 | { desc "edit the word at point" } 76 | } 77 | } 78 | } 79 | } 80 | T{ area 81 | { name "general" } 82 | { shortcuts 83 | { 84 | T{ shortcut 85 | { key "C-g" } 86 | { desc "abort the current operation" } 87 | } 88 | T{ shortcut 89 | { key "C-x C-v RET" } 90 | { desc "reload the buffers file (using find alterate file)" } 91 | } 92 | T{ shortcut 93 | { key "C-u C-x =" } 94 | { desc "describe character at point" } 95 | } 96 | } 97 | } 98 | } 99 | T{ area 100 | { name "ido-mode" } 101 | { shortcuts 102 | { 103 | T{ shortcut 104 | { key "C-k" } 105 | { desc "kill matched buffer" } 106 | } 107 | } 108 | } 109 | } 110 | T{ area 111 | { name "ibuffer" } 112 | { shortcuts 113 | { 114 | T{ shortcut 115 | { key "D" } 116 | { desc "kill marked buffer" } 117 | } 118 | } 119 | } 120 | } 121 | T{ area 122 | { name "magit-status" } 123 | { shortcuts 124 | { 125 | T{ shortcut 126 | { key "F F" } 127 | { desc "run git pull" } 128 | } 129 | T{ shortcut 130 | { key "k" } 131 | { desc "delete an untracked file" } 132 | } 133 | T{ shortcut 134 | { key "b v" } 135 | { desc "list local and remote branches" } 136 | } 137 | T{ shortcut 138 | { key "g" } 139 | { desc "refresh the status buffer" } 140 | } 141 | } 142 | } 143 | } 144 | T{ area 145 | { name "nxml-mode" } 146 | { shortcuts 147 | { 148 | T{ shortcut 149 | { key "C-c C-f" } 150 | { desc "insert end tag for element containing point" } 151 | } 152 | } 153 | } 154 | } 155 | } 156 | 157 | : printff ( -- ) 158 | printf flush ; inline 159 | 160 | : ask-shortcut ( name shortcut -- ? ) 161 | [ desc>> "In *%s*, what is the shortcut to \"%s\"?\n> " printff ] 162 | [ key>> readln = ] bi dup "Correct!" "Wrong!" ? print flush ; 163 | 164 | : shortcuts-flat ( -- shortcuts ) 165 | shortcut-areas 166 | [ [ name>> ] [ shortcuts>> ] bi [ 2array ] with map ] map concat ; 167 | 168 | : training-game ( -- ) 169 | shortcuts-flat 5 sample [ first2 ask-shortcut ] map sift 170 | length "You scored %d points!\n" printf flush ; 171 | -------------------------------------------------------------------------------- /examples/alien/assembler/assembler.factor: -------------------------------------------------------------------------------- 1 | USING: alien alien.c-types alien.data alien.syntax 2 | compiler.codegen.labels compiler.codegen.relocation 3 | cpu.x86.64 cpu.x86.assembler cpu.x86.assembler.operands 4 | kernel namespaces random sequences specialized-arrays ; 5 | IN: examples.alien.callbacks 6 | 7 | LIBRARY: libc 8 | 9 | FUNCTION: void qsort ( void* base, 10 | size_t num, 11 | size_t width, 12 | void* func ) 13 | 14 | SPECIALIZED-ARRAY: uint 15 | 16 | CALLBACK: int comparer ( void* arg1, void* arg2 ) 17 | 18 | : assembly-compare ( uint1* uint2* -- -1/0/1 ) 19 | init-relocation 20 | int { void* void* } cdecl [ 21 | "gt" "lt" "end" [ define-label ] tri@ 22 | RBP 0xffff0000 MOV 23 | ! Remember that these are 32 bit numbers. 24 | EBX param-reg-0 [] MOV 25 | ECX param-reg-1 [] MOV 26 | EBX ECX CMP 27 | "gt" get JG 28 | "lt" get JL 29 | RAX 0 MOV 30 | "end" get JMP 31 | "gt" resolve-label 32 | RAX 1 MOV 33 | "end" get JMP 34 | "lt" resolve-label 35 | RAX -1 MOV 36 | "end" resolve-label 37 | ] alien-assembly ; 38 | 39 | : ( -- alien ) 40 | int { pointer: void pointer: void } cdecl 41 | [ assembly-compare ] alien-callback ; 42 | 43 | : random-array ( length -- seq ) 44 | [ 100 random ] replicate ; 45 | 46 | : qsort-seq ( seq type -- seq' ) 47 | 2dup >c-array [ 48 | -rot [ length ] [ heap-size ] bi* qsort 49 | ] keep ; 50 | -------------------------------------------------------------------------------- /examples/alien/callbacks/callbacks.factor: -------------------------------------------------------------------------------- 1 | USING: alien alien.accessors alien.c-types alien.data 2 | alien.syntax kernel math math.functions random sequences 3 | specialized-arrays trees.private ; 4 | IN: examples.alien.callbacks 5 | 6 | LIBRARY: libc 7 | 8 | FUNCTION: void qsort ( void* base, 9 | size_t num, 10 | size_t width, 11 | void* func ) 12 | 13 | SPECIALIZED-ARRAY: uint 14 | 15 | CALLBACK: int comparer ( void* arg1, void* arg2 ) 16 | 17 | : ( -- alien ) 18 | [ 19 | [ 0 alien-unsigned-4 ] bi@ key-side 20 | ] comparer ; 21 | 22 | : random-array ( length -- seq ) 23 | [ 100 random ] replicate ; 24 | 25 | : qsort-seq ( seq type -- seq' ) 26 | 2dup >c-array [ 27 | -rot [ length ] [ heap-size ] bi* qsort 28 | ] keep ; 29 | -------------------------------------------------------------------------------- /examples/alien/structs/structs.factor: -------------------------------------------------------------------------------- 1 | ! How to construct a linked list in malloc:ed memory. 2 | USING: accessors alien.c-types classes.struct kernel libc sequences 3 | sequences.shifted ; 4 | IN: examples.alien.structs 5 | 6 | STRUCT: node 7 | { value int } 8 | { next node* } ; 9 | 10 | : make-list ( seq -- nodes ) 11 | [ node malloc-struct &free swap >>value ] map 12 | dup 1 f [ >>next ] 2map last ; 13 | -------------------------------------------------------------------------------- /examples/bugs/bug1021/bug1021.factor: -------------------------------------------------------------------------------- 1 | USING: alien alien.c-types alien.libraries alien.libraries.finder alien.syntax 2 | arrays formatting io io.pathnames kernel kernel.private math math.private 3 | sequences slots.private system ; 4 | IN: examples.bugs.bug1021 5 | 6 | << "factor-ffi-test" dup os windows? [ "lib" prepend ] when 7 | find-library absolute-path cdecl add-library >> 8 | 9 | LIBRARY: factor-ffi-test 10 | 11 | FUNCTION: void* bug1021_test_1 ( void* s, int x ) 12 | 13 | : dummy ( -- ) ; 14 | 15 | : each-to100 ( ... quot: ( ... i -- ... ) i -- ... ) 16 | dup 100 < [ 17 | 2dup swap (call) 1 + each-to100 18 | ] [ 2drop ] if ; inline recursive 19 | 20 | : run-test ( alien -- seq ) 21 | 100 33 swap over 22 | [ 23 | pick swapd 24 | bug1021_test_1 25 | ! dummy 26 | -rot swap 2 fixnum+fast 27 | 28 | set-slot 29 | ] curry curry 0 each-to100 ; 30 | 31 | : small-ex ( -- ) 32 | [ 33 | "%d loop!\n" printf flush 34 | 101 run-test [ alien-address ] map drop 35 | ] 2000 iota swap each ; 36 | 37 | ! This example doesn't fail unless you apply my pr which empties the 38 | ! nursery because of shadow data. 39 | FUNCTION: int bug1021_test_2 ( int a, char* b, void* c ) 40 | FUNCTION: void* bug1021_test_3 ( c-string a ) 41 | USING: byte-arrays alien.strings ; 42 | 43 | : doit ( a -- d ) 44 | 33 1byte-array "bar" bug1021_test_3 bug1021_test_2 ; 45 | 46 | : doit-tests ( -- ) 47 | 100000 [ 0 doit 33 assert= ] times ; 48 | -------------------------------------------------------------------------------- /examples/bugs/bug1130/bug1130.factor: -------------------------------------------------------------------------------- 1 | USING: alien alien.accessors alien.c-types combinators compiler.units kernel 2 | math sequences windows.com windows.com.syntax windows.com.wrapper 3 | windows.com.wrapper.private windows.ole32 windows.types ; 4 | IN: examples.bugs.bug1130 5 | 6 | COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} 7 | HRESULT returnOK ( ) 8 | HRESULT returnError ( ) ; 9 | 10 | : simple-wrapper ( -- ) 11 | ISimple 12 | { 13 | [ 14 | swap { 15 | { GUID: {00000000-0000-0000-c000-000000000046} [ 0 ] } 16 | { GUID: {216fb341-0eb2-44b1-8edb-60b76e353abc} [ 0 ] } 17 | [ drop f ] 18 | } case 19 | [ 20 | void* heap-size * rot com-add-ref 21 | swap 0 set-alien-cell S_OK 22 | ] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if* 23 | ] 24 | } 25 | { } 1 (make-interface-callbacks) 26 | [ execute( -- callback ) drop ] each ; 27 | 28 | : small-ex ( -- ) 29 | 1200 [ [ simple-wrapper ] with-compilation-unit ] times ; 30 | -------------------------------------------------------------------------------- /examples/bugs/bug1130/platforms.txt: -------------------------------------------------------------------------------- 1 | windows 2 | -------------------------------------------------------------------------------- /examples/bugs/bug1187/bug1187.factor: -------------------------------------------------------------------------------- 1 | USING: io kernel sequences ; 2 | IN: examples.bugs.bug1187 3 | 4 | : do-test ( x y -- z ) 2dup [ print ] bi@ append ; 5 | -------------------------------------------------------------------------------- /examples/bugs/bug1339/bug1339.factor: -------------------------------------------------------------------------------- 1 | USING: arrays bit-arrays formatting fry kernel kernel.private math 2 | math.private sequences sequences.private ; 3 | IN: examples.bugs.bug1339 4 | 5 | : my-nth-unsafe ( n seq -- el ) 6 | [ { array-capacity } declare ] dip nth-unsafe ; inline 7 | 8 | : bar2 ( n -- m ) 9 | [ 0 ] dip dup 10 | '[ _ nth [ 77 + ] when ] each-integer ; 11 | 12 | : bar ( n -- m ) 13 | [ 0 ] dip dup 14 | '[ _ nth-unsafe [ 77 + ] when ] each-integer ; 15 | 16 | : bar3 ( n -- m ) 17 | [ 0 ] dip dup length swap 18 | '[ _ nth-unsafe [ 77 + ] when ] each-integer ; 19 | 20 | : ok ( x y z -- ) 21 | "%u %u %u\n" printf ; 22 | 23 | : foo ( n -- m ) 24 | 0 0 rot 25 | dup 3 26 | [ 27 | ! 3dup ok 28 | bounds-check 29 | [ integer>fixnum ] dip array-nth + 30 | ] curry 31 | (each-integer) ; 32 | 33 | : (foo3) ( seq sum n len -- sum' ) 34 | 2dup < [ 35 | ! seq sum n len 36 | [ 37 | ! seq sum n | len 38 | pick dupd 39 | ! seq sum n n seq | len 40 | ! 2dup 1 slot { array-capacity } declare < [ bounds-error ] unless 41 | ! nth 42 | nth-unsafe 43 | ! seq sum n el | len 44 | rot + 45 | ! seq n sum' | len 46 | swap 1 + 47 | ] dip 48 | ! seq sum' n len 49 | (foo3) 50 | ] [ 2drop nip ] if ; inline recursive 51 | 52 | : ( n el -- m ) 53 | [ { array-capacity } declare ] dip ; inline 54 | 55 | : foo3 ( n -- m ) 56 | dup 3 57 | ! n n 3 58 | 59 | ! n arr 60 | 0 rot 61 | ! arr 0 n 62 | 0 swap 63 | ! arr 0 0 n 64 | (foo3) ; inline 65 | 66 | 67 | ! Better each 68 | : ((my-each)) ( seq -- n quot ) 69 | [ length check-length 70 | integer>fixnum 71 | ] keep [ nth-unsafe ] curry ; inline 72 | 73 | : (my-each) ( seq quot -- n quot' ) [ ((my-each)) ] dip compose ; 74 | inline 75 | 76 | : my-each ( ... seq quot: ( ... x -- ... ) -- ... ) 77 | (my-each) each-integer ; inline 78 | -------------------------------------------------------------------------------- /examples/bugs/bug1507/bug1507.factor: -------------------------------------------------------------------------------- 1 | USING: arrays kernel kernel.private math math.private sequences 2 | sequences.private slots.private ; 3 | IN: examples.bugs.bug1507 4 | 5 | : my-new-key4 ( a i j -- i/j ) 6 | 2over 7 | slot 8 | swap over 9 | ! a i el j el 10 | [ 11 | ! a i el j 12 | swap 13 | ! a i j el 14 | 77 eq? 15 | [ 16 | rot drop and 17 | ] 18 | [ 19 | ! a i j 20 | over or my-new-key4 21 | ] if 22 | ] 23 | [ 24 | ! a i el j 25 | 2drop t 26 | ! a i t 27 | my-new-key4 28 | ] if ; inline recursive 29 | 30 | : badword ( y -- ) 31 | 0 swap dup 32 | { integer object } declare 33 | [ 34 | { array-capacity object } declare nip 35 | 1234 1234 pick 36 | f 37 | my-new-key4 38 | set-slot 39 | ] 40 | curry (each-integer) ; 41 | -------------------------------------------------------------------------------- /examples/bugs/bug1559/README.txt: -------------------------------------------------------------------------------- 1 | with subseq: 2 | ----------- 3 | [ 4 | >R { } 0 5 | { vector 2 1 tuple 236985587512 vector 8369605308162 } 6 | 0 R> 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 7 | \ ( gensym ) [ 8 | 2dup 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 9 | dup >R dup >R 1 slot R> \ ( gensym ) [ 10 | pick pick fixnum< [ 11 | ( 8670945 8670949 8673131 -- 8670945 8673131 8670945 8670949 8673131 ) 12 | >R >R >R >R R> 2dup string-nth-fast 13 | dup 127 fixnum<= 14 | [ 2nip ] [ 15 | >R 2 slot swap 1 fixnum-shift-fast 16 | alien-unsigned-2 7 fixnum-shift-fast 17 | R> fixnum-bitxor 18 | ] if dup 13 eq? [ \ t ] [ f ] if 19 | [ drop \ t ] [ 20 | 10 eq? [ \ t ] [ f ] if 21 | [ \ t ] [ f ] if 22 | ] if R> R> R> >R rot R> swap 23 | [ 2drop ] [ 24 | "COMPLEX SHUFFLE" 1 fixnum+fast 25 | "COMPLEX SHUFFLE" ( gensym ) 26 | ] if 27 | ] [ 3drop f ] if 28 | ] label R> over [ 29 | dupd >R R> 2dup string-nth-fast 30 | dup 127 fixnum<= 31 | [ 2nip ] [ 32 | >R 2 slot swap 1 fixnum-shift-fast 33 | alien-unsigned-2 7 fixnum-shift-fast 34 | R> fixnum-bitxor 35 | ] if 36 | ] [ drop f ] if 37 | ] [ 2drop f f ] if swapd >R over 38 | [ ] [ dup >R nip 1 slot R> ] if 2dup >R >R subseq 39 | over dup >R 3 slot R> 2dup 3 slot fixnum>= [ 40 | 2dup 2 slot 1 slot fixnum>= [ 41 | over 1 fixnum+fast 2 fixnum* 42 | over dup >R 2 slot resize-array 43 | R> swap swap >R R> 2 set-slot 44 | ] [ ] if >R R> over 1 fixnum+fast 45 | over >R 288230376151711743 fixnum-bitand 46 | R> 3 set-slot 47 | ] [ >R R> ] if 2 slot >R R> swap 2 fixnum+fast 48 | set-slot R> R> >R 1 fixnum+fast R> R> 13 eq? [ 49 | 2dup 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 50 | >R R> 2dup string-nth-fast dup 127 fixnum<= 51 | [ 2nip ] [ 52 | >R 2 slot swap 1 fixnum-shift-fast 53 | alien-unsigned-2 7 fixnum-shift-fast 54 | R> fixnum-bitxor 55 | ] if 56 | ] [ 2drop f ] if 10 eq? 57 | [ >R 1 fixnum+fast R> ] [ ] if 58 | ] [ ] if 2dup 1 slot fixnum< [ \ t ] [ f ] if 59 | [ ( gensym ) ] 60 | [ ( 8671129 8671133 8671134 -- 8671129 ) ] if 61 | ] label 62 | ] [ ( 8670814 8670829 8670830 -- 8670814 ) ] if 63 | dup >R 3 slot R> 2 slot 2dup 1 slot eq? 64 | [ nip ] [ resize-array ] if 65 | ] 66 | 67 | with subseq-unsafe: 68 | ----------- 69 | [ 70 | >R { } 0 71 | { vector 2 1 tuple 236985587512 vector 8369605308162 } 72 | 0 R> 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 73 | \ ( gensym ) [ 74 | 2dup 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 75 | dup >R dup >R 1 slot R> \ ( gensym ) [ 76 | pick pick fixnum< [ 77 | ( 8678886 8678890 8681072 -- 8678886 8681072 8678886 8678890 8681072 ) 78 | >R >R >R >R R> 2dup string-nth-fast 79 | dup 127 fixnum<= 80 | [ 2nip ] [ 81 | >R 2 slot swap 1 fixnum-shift-fast 82 | alien-unsigned-2 7 fixnum-shift-fast 83 | R> fixnum-bitxor 84 | ] if dup 13 eq? [ \ t ] [ f ] if 85 | [ drop \ t ] [ 86 | 10 eq? [ \ t ] [ f ] if 87 | [ \ t ] [ f ] if 88 | ] if R> R> R> >R rot R> swap 89 | [ 2drop ] [ 90 | "COMPLEX SHUFFLE" 1 fixnum+fast 91 | "COMPLEX SHUFFLE" ( gensym ) 92 | ] if 93 | ] [ 3drop f ] if 94 | ] label R> over [ 95 | dupd >R R> 2dup string-nth-fast 96 | dup 127 fixnum<= 97 | [ 2nip ] [ 98 | >R 2 slot swap 1 fixnum-shift-fast 99 | alien-unsigned-2 7 fixnum-shift-fast 100 | R> fixnum-bitxor 101 | ] if 102 | ] [ drop f ] if 103 | ] [ 2drop f f ] if swapd >R over 104 | [ ] [ dup >R nip 1 slot R> ] if 105 | 2dup >R >R subseq-unsafe over dup >R 3 slot 106 | R> 2dup 3 slot fixnum>= [ 107 | 2dup 2 slot 1 slot fixnum>= [ 108 | over 1 fixnum+fast 2 fixnum* 109 | over dup >R 2 slot resize-array 110 | R> swap swap >R R> 2 set-slot 111 | ] [ ] if >R R> over 1 fixnum+fast 112 | over >R 288230376151711743 fixnum-bitand 113 | R> 3 set-slot 114 | ] [ >R R> ] if 2 slot >R R> swap 2 fixnum+fast 115 | set-slot R> R> >R 1 fixnum+fast R> R> 13 eq? [ 116 | 2dup 2dup 1 slot fixnum< [ \ t ] [ f ] if [ 117 | >R R> 2dup string-nth-fast dup 127 fixnum<= 118 | [ 2nip ] [ 119 | >R 2 slot swap 1 fixnum-shift-fast 120 | alien-unsigned-2 7 fixnum-shift-fast 121 | R> fixnum-bitxor 122 | ] if 123 | ] [ 2drop f ] if 10 eq? 124 | [ >R 1 fixnum+fast R> ] [ ] if 125 | ] [ ] if 2dup 1 slot fixnum< [ \ t ] [ f ] if 126 | [ ( gensym ) ] 127 | [ ( 8679070 8679074 8679075 -- 8679070 ) ] if 128 | ] label 129 | ] [ ( 8678755 8678770 8678771 -- 8678755 ) ] if 130 | dup >R 3 slot R> 2 slot 2dup 1 slot eq? 131 | [ nip ] [ resize-array ] if 132 | ] 133 | -------------------------------------------------------------------------------- /examples/bugs/bug1559/bug1559.factor: -------------------------------------------------------------------------------- 1 | USING: arrays hints kernel kernel.private math sequences 2 | sequences.private strings ; 3 | IN: examples.bugs.bug1559 4 | 5 | : my-subseq-unsafe ( from to seq -- subseq ) 6 | [ { array-capacity array-capacity } declare ] dip 7 | [ subseq>copy (copy) ] keep like ; 8 | 9 | : my-subseq ( from to seq -- subseq ) 10 | [ check-slice subseq>copy (copy) ] keep like ; 11 | 12 | { my-subseq my-subseq-unsafe } [ 13 | { { fixnum fixnum string } { fixnum fixnum array } } 14 | set-specializer 15 | ] each 16 | 17 | : my-subseq-unsafe-fixnum ( from to seq -- subseq ) 18 | { array-capacity array-capacity array } declare 19 | [ subseq>copy (copy) ] keep like ; 20 | 21 | : my-subseq-fixnum ( from to seq -- subseq ) 22 | { fixnum fixnum array } declare 23 | [ check-slice subseq>copy (copy) ] keep like ; 24 | 25 | 26 | 27 | 28 | 29 | GENERIC: gen-string-lines ( str -- lines ) 30 | M: string gen-string-lines 31 | [ V{ } clone 0 ] dip [ 2dup bounds-check? ] [ 32 | 2dup [ "\r\n" member? ] find-from swapd [ 33 | over [ [ nip length ] keep ] unless 34 | [ my-subseq-unsafe suffix! ] 2keep [ 1 + ] dip 35 | ] dip CHAR: \r eq? [ 36 | 2dup ?nth CHAR: \n eq? [ [ 1 + ] dip ] when 37 | ] when 38 | ] while 2drop { } like ; 39 | -------------------------------------------------------------------------------- /examples/bugs/bug1571/bug1571.factor: -------------------------------------------------------------------------------- 1 | USING: math sequences.private ; 2 | IN: examples.bugs.bug1571 3 | 4 | TUPLE: foo { a fixnum } ; ! OK 5 | TUPLE: foo3 { a float } ; ! OK 6 | TUPLE: foo1 { a array-capacity } ; ! OK 7 | TUPLE: foo2 { a integer-array-capacity } ; 8 | TUPLE: foo4 { a bignum } ; ! OK 9 | -------------------------------------------------------------------------------- /examples/bugs/bug677/bug677.factor: -------------------------------------------------------------------------------- 1 | USING: arrays kernel.private math sequences ; 2 | IN: examples.bugs.bug677 3 | 4 | : sum-fast ( array -- n ) 5 | { array } declare 6 | 0 [ + ] binary-reduce ; inline 7 | -------------------------------------------------------------------------------- /examples/bugs/bug789/bug789.factor: -------------------------------------------------------------------------------- 1 | USING: formatting kernel kernel.private math memory sequences.private 2 | tools.time ; 3 | IN: examples.bugs.bug789 4 | 5 | : foo1 ( x -- n ) { array-capacity } declare 200000000 [ 1 + ] times ; 6 | 7 | : foo2 ( x -- n ) 8 | { array-capacity } declare 200000000 [ { array-capacity } declare 1 + ] times ; 9 | 10 | : time2 ( -- ) 11 | gc [ 10 foo2 drop ] time ; 12 | 13 | : main ( -- ) 14 | time2 ; 15 | 16 | MAIN: main 17 | -------------------------------------------------------------------------------- /examples/bugs/bug839/bug839.factor: -------------------------------------------------------------------------------- 1 | USING: io kernel kernel.private math prettyprint sequences sequences.private ; 2 | IN: examples.bugs.bug839 3 | 4 | : foo ( seq -- ? ) 5 | [ 42 < ] all? ; 6 | 7 | : foo2 ( seq -- ? ) 8 | [ 42 < ] setup-each all-integers? ; 9 | 10 | : foo3 ( seq -- ? ) 11 | dup length swap [ nth-unsafe 42 < ] curry all-integers? ; 12 | 13 | : foo4 ( seq -- ? ) 14 | 0 over length rot [ nth-unsafe 42 < ] curry (all-integers?) ; 15 | 16 | : each-to10 ( ... quot: ( ... i -- ... ) i -- ... ) 17 | dup 10 < [ 18 | 2dup swap call 1 + each-to10 19 | ] [ 2drop ] if ; inline recursive 20 | 21 | : foo5 ( seq -- ) 22 | [ nth-unsafe unparse print ] curry 0 each-to10 ; 23 | -------------------------------------------------------------------------------- /examples/compiler/tree-builder/tree-builder-tests.factor: -------------------------------------------------------------------------------- 1 | USING: classes.tuple compiler.tree compiler.tree.optimizer 2 | examples.compiler.tree-builder fry kernel math namespaces sequences 3 | stack-checker.values tools.test ; 4 | IN: examples.compiler.tree-builder.tests 5 | 6 | ! Because node is an identity-tuple 7 | : node-seqs-eq? ( seq1 seq2 -- ? ) 8 | [ [ tuple-slots ] map concat ] bi@ = ; 9 | 10 | : tree-generator-test ( nodes quot -- ) 11 | swap '[ 0 \ set-global _ quot>tree _ node-seqs-eq? ] { t } swap 12 | unit-test ; 13 | 14 | { 15 | T{ #push { literal 33 } { out-d { 1 } } } 16 | T{ #return { in-d { 1 } } } 17 | } [ 33 ] tree-generator-test 18 | 19 | : foo ( x -- ) 20 | drop ; 21 | { 22 | T{ #push { literal [ foo ] } { out-d { 1 } } } 23 | T{ #return { in-d { 1 } } } 24 | } [ [ foo ] ] tree-generator-test 25 | 26 | { 27 | T{ #push { literal 3 } { out-d { 1 } } } 28 | T{ #call { word foo } { in-d { 1 } } { out-d { } } } 29 | T{ #return { in-d { } } } 30 | } [ 3 foo ] tree-generator-test 31 | 32 | : foo1 ( x -- y ) 33 | ; 34 | 35 | { 36 | T{ #push { literal 4 } { out-d { 1 } } } 37 | T{ #call 38 | { word foo1 } 39 | { in-d { 1 } } 40 | { out-d { 2 } } 41 | } 42 | T{ #return { in-d { 2 } } } 43 | } [ 4 foo1 ] tree-generator-test 44 | 45 | { 46 | T{ #introduce { out-d { 1 2 } } } 47 | T{ #shuffle 48 | { mapping { { 3 1 } { 4 2 } { 5 1 } } } 49 | { in-d { 1 2 } } 50 | { out-d { 3 4 5 } } 51 | } 52 | T{ #return { in-d { 3 4 5 } } } 53 | } [ over ] tree-generator-test 54 | 55 | { 56 | T{ #push { literal [ 3 foo ] } { out-d { 1 } } } 57 | T{ #shuffle { mapping { } } { in-d { 1 } } { out-d { } } } 58 | T{ #push { literal 3 } { out-d { 2 } } } 59 | T{ #call { word foo } { in-d { 2 } } { out-d { } } } 60 | T{ #return { in-d { } } } 61 | } [ [ 3 foo ] call ] tree-generator-test 62 | 63 | { } [ 64 | [ 7 ] quot>tree optimize-tree drop 65 | ] unit-test 66 | 67 | ! build-tree optimize-tree gensym build-cfg first dup optimize-cfg cfg. 68 | -------------------------------------------------------------------------------- /examples/compiler/tree-builder/tree-builder.factor: -------------------------------------------------------------------------------- 1 | USING: accessors arrays assocs compiler.tree effects kernel locals 2 | make math math.order namespaces sequences stack-checker.backend 3 | stack-checker.values words ; 4 | IN: examples.compiler.tree-builder 5 | 6 | SYMBOL: literals 7 | 8 | DEFER: make-nodes 9 | DEFER: (quot>tree) 10 | 11 | 12 | ! Canned instruction creators 13 | : drop-shuffle ( value -- ) 14 | { } swap 1array { } f f #shuffle boa , ; 15 | 16 | ! known words 17 | : my-infer-call ( ds -- ds' ) 18 | unclip-last dup drop-shuffle literals get at swap (quot>tree) ; 19 | 20 | : my-infer-dip ( ds -- ds' ) 21 | my-infer-call \ swap make-nodes ; 22 | 23 | CONSTANT: special-words { 24 | { call my-infer-call } 25 | { dip my-infer-dip } 26 | } 27 | 28 | : cut-remaining ( seq n -- before after missing ) 29 | [ short cut* ] [ swap length - 0 max ] 2bi ; 30 | 31 | : measure-effect ( effect -- in out ) 32 | [ in>> ] [ out>> ] bi [ length ] bi@ ; 33 | 34 | : consume-inputs ( ds in -- ds' values ) 35 | cut-remaining make-values dup [ #introduce boa , ] unless-empty prepend ; 36 | 37 | : consume/produce ( ds in out -- ins outs ds' ) 38 | [ consume-inputs ] [ make-values rot over append ] bi* ; 39 | 40 | PREDICATE: shuffle-word < word "shuffle" word-prop ; 41 | 42 | GENERIC: make-nodes ( ds obj -- ds' ) 43 | 44 | :: concreete-word ( ds obj -- ds' ) 45 | obj required-stack-effect :> eff 46 | ds eff measure-effect consume/produce :> ( ins outs ds' ) 47 | obj shuffle-word? 48 | [ outs ins eff shuffle zip ins outs f f #shuffle boa ] 49 | [ obj ins outs f f f f #call boa ] if , ds' ; 50 | 51 | M: word make-nodes ( ds obj -- ds' ) 52 | dup special-words at [ nip execute( x -- x' ) ] [ concreete-word ] if* ; 53 | 54 | M: object make-nodes ( ds obj -- ds' ) 55 | 56 | [ 1array #push boa , ] 57 | [ literals get set-at ] 58 | [ nip suffix ] 2tri ; 59 | 60 | : make-return ( ds -- ) 61 | f #return boa , ; 62 | 63 | : (quot>tree) ( quot ds -- ds' ) 64 | [ make-nodes ] reduce ; 65 | 66 | : quot>tree ( quot -- nodes ) 67 | H{ } clone literals set [ { } (quot>tree) make-return ] { } make ; 68 | -------------------------------------------------------------------------------- /examples/deploy/mini/authors.txt: -------------------------------------------------------------------------------- 1 | Björn Lindqvist 2 | -------------------------------------------------------------------------------- /examples/deploy/mini/features/features.factor: -------------------------------------------------------------------------------- 1 | IN: examples.deploy.mini.features 2 | 3 | SYMBOL: global-hash? 4 | SYMBOL: required-classes 5 | SYMBOL: required-vars 6 | SYMBOL: quotation-compiler? 7 | SYMBOL: word-names? 8 | -------------------------------------------------------------------------------- /examples/deploy/mini/generics/generics-tests.factor: -------------------------------------------------------------------------------- 1 | USING: arrays tools.test ; 2 | IN: examples.deploy.mini.generics.tests 3 | 4 | { t } [ 5 | t 6 | ] unit-test 7 | -------------------------------------------------------------------------------- /examples/deploy/mini/generics/generics.factor: -------------------------------------------------------------------------------- 1 | USING: arrays assocs classes.mixin classes.tuple.private compiler.units 2 | compiler.units.private definitions examples.deploy.mini.utils fry 3 | generic kernel memory namespaces sequences strings vectors vocabs 4 | words ; 5 | IN: examples.deploy.mini.generics 6 | QUALIFIED: sets 7 | 8 | : filter-generic ( generic classes -- ) 9 | [ "methods" word-prop values ] dip 10 | '[ "method-class" word-prop _ member? ] reject 11 | [ forget ] each ; 12 | 13 | : filter-generics ( generics classes -- ) 14 | '[ _ filter-generic ] each ; 15 | 16 | : begin-simple-compilation-unit ( -- ) 17 | V{ } clone definition-observers set-global 18 | V{ } clone vocab-observers set-global 19 | new-definitions set 20 | old-definitions set 21 | HS{ } clone forgotten-definitions set 22 | HS{ } clone changed-definitions set 23 | HS{ } clone maybe-changed set 24 | HS{ } clone changed-effects set 25 | HS{ } clone outdated-generics set 26 | HS{ } clone new-words set 27 | H{ } clone outdated-tuples set ; 28 | 29 | : finish-simple-compilation-unit ( -- ) 30 | "Remaking generics..." safe-show 31 | remake-generics 32 | to-recompile [ 33 | dup length "Recompiling %d words..." printff 34 | recompile 35 | outdated-tuples get update-tuples 36 | forgotten-definitions get process-forgotten-definitions 37 | ] keep update-existing? reset-pics? 38 | "Modifying code heap..." safe-show 39 | modify-code-heap ; 40 | 41 | : with-simple-compilation-unit ( quot -- ) 42 | begin-simple-compilation-unit 43 | call finish-simple-compilation-unit ; inline 44 | 45 | : instances-to-remove ( classes mixin -- instances ) 46 | "instances" word-prop keys swap sets:diff ; 47 | 48 | : filter-mixin ( classes mixin -- ) 49 | [ 50 | instances-to-remove 51 | dup "Removing instances %u\n" printff 52 | ] keep 53 | '[ _ remove-mixin-instance ] each ; 54 | ! 2drop ; 55 | 56 | : filter-mixins ( classes -- ) 57 | dup [ "mixin" word-prop ] filter [ filter-mixin ] with each ; 58 | 59 | : forget-other-methods ( generics classes -- ) 60 | "Recompiling generics..." safe-show 61 | [ 62 | dup filter-mixins 63 | filter-generics 64 | ] with-simple-compilation-unit ; 65 | -------------------------------------------------------------------------------- /examples/deploy/mini/globals/globals.factor: -------------------------------------------------------------------------------- 1 | USING: accessors assocs compiler.units definitions 2 | examples.deploy.mini.utils fry kernel kernel.private namespaces 3 | namespaces.private sequences words ; 4 | IN: examples.deploy.mini.globals 5 | 6 | : uninline-word ( word -- ) 7 | [ f "flushable" set-word-prop ] 8 | [ f "foldable" set-word-prop ] 9 | [ [ changed-definition ] with-compilation-unit ] tri ; 10 | 11 | : uninline-globals-word ( -- ) 12 | "Uninlining global word..." safe-show 13 | \ global uninline-word ; 14 | 15 | : copy-global-vars ( required-vars -- globals ) 16 | "Copying global variables..." safe-show 17 | global boxes>> [ drop member? ] with assoc-filter global-hashtable boa ; 18 | -------------------------------------------------------------------------------- /examples/deploy/mini/mini.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: arrays examples.deploy.mini.features examples.deploy.mini.generics 4 | examples.deploy.mini.globals examples.deploy.mini.utils 5 | examples.deploy.mini.word-stripping generic io.backend io.pathnames kernel 6 | kernel.private literals locals memory memory.private namespaces parser 7 | sequences slots.private strings vectors vocabs vocabs.loader words ; 8 | IN: examples.deploy.mini 9 | 10 | : strip-jit-compiler ( -- ) 11 | "Stripping JIT compiler..." safe-show 12 | 13 | ! JIT removal, must be done almost last. 14 | JIT-PROLOG JIT-DECLARE-WORD clear-specials 15 | 16 | ! PIC things, megamorphic caches, undefined and stderr 17 | PIC-LOAD OBJ-STDERR clear-specials ; 18 | 19 | : clean-special-words ( redir-word -- ) 20 | "Setting images main word..." safe-show 21 | ! Primitive words that are required for generics, but whose code 22 | ! blocks we can overwrite. 23 | ${ 24 | C-TO-FACTOR-WORD 25 | JIT-DIP-WORD 26 | JIT-IF-WORD 27 | JIT-PRIMITIVE-WORD 28 | } [ 29 | dup f swap special-object 8 set-slot 30 | [ 9 slot ] dip special-object 9 set-slot 31 | ] with each ; 32 | 33 | ! These are the classes that are required to finish deploying the 34 | ! image. 35 | CONSTANT: base-classes { 36 | array string vector 37 | } 38 | 39 | :: word>factor-image ( image-path word features -- ) 40 | "Baking the image..." safe-show 41 | 42 | image-path normalize-path saving-path :> ( saving-path real-path ) 43 | 44 | features global-hash? safe-of [ 45 | uninline-globals-word 46 | features required-vars safe-of copy-global-vars 47 | ] [ f ] if :> new-globals 48 | 49 | ! After generic stripping we have to be *very* careful because a 50 | ! lot of words won't work. 51 | [ generic? ] instances 52 | features required-classes safe-of base-classes append 53 | forget-other-methods 54 | 55 | new-globals OBJ-GLOBAL set-special-object 56 | 57 | "Stripping words..." safe-show 58 | features word-names? safe-of strip-words 59 | 60 | word clean-special-words 61 | 62 | ! Startup quot, global and shutdown quot 63 | f OBJ-STARTUP-QUOT set-special-object 64 | f OBJ-SHUTDOWN-QUOT set-special-object 65 | 66 | ! Canonicals 67 | f OBJ-BIGNUM-ZERO set-special-object 68 | f OBJ-BIGNUM-POS-ONE set-special-object 69 | f OBJ-BIGNUM-NEG-ONE set-special-object 70 | f OBJ-CANONICAL-TRUE set-special-object 71 | 72 | ! It's fine as long as the value is != f 73 | 20 OBJ-STAGE2 set-special-object 74 | 75 | ! Entry points and signal handlers we can do without 76 | LAZY-JIT-COMPILE-WORD REDEFINITION-COUNTER clear-specials 77 | 78 | f OBJ-UNDEFINED set-special-object 79 | 80 | features quotation-compiler? safe-of [ 81 | strip-jit-compiler 82 | ] unless 83 | 84 | saving-path real-path t (save-image) ; 85 | 86 | : vocab-main-and-features ( vocab-name -- main-word features ) 87 | [ load-vocab vocab-main dup "loc" word-prop first run-file ] 88 | [ "features" swap lookup-word execute( -- assoc ) ] bi ; 89 | 90 | : vocab-and-output ( -- vocab output ) 91 | "deploy-vocab" get "output-image" get [ dup ".image" append ] unless* ; 92 | 93 | : main ( -- ) 94 | current-directory get vocab-roots get push 95 | 96 | vocab-and-output 97 | 2dup "Deploying %u to %u..." printff 98 | swap vocab-main-and-features word>factor-image ; 99 | 100 | MAIN: main 101 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/maybe.image: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bjourne/playground-factor/8a1d272127ac69225d067308e0787315ef2b88a1/examples/deploy/mini/tests/maybe.image -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test01/test01.factor: -------------------------------------------------------------------------------- 1 | USING: examples.deploy.mini.features kernel system ; 2 | IN: examples.deploy.mini.tests.test01 3 | 4 | ! Words : (exit) main-word t c-to-factor 5 | ! Quotations : [ ] 6 | ! Code blocks: (exit) main-word/c-to-factor [ ] 7 | ! 64-bit size: 1 496 8 | CONSTANT: features { 9 | { quotation-compiler? f } 10 | { required-classes { } } 11 | { global-hash? f } 12 | } 13 | 14 | : main-word ( -- ) 99 (exit) ; 15 | 16 | MAIN: main-word 17 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test02/test02.factor: -------------------------------------------------------------------------------- 1 | USING: byte-arrays examples.deploy.mini.features io.streams.c kernel 2 | math sequences sequences.private ; 3 | IN: examples.deploy.mini.tests.test02 4 | 5 | ! 64-bit size: 2 616 (3 128) 6 | ! Purpose : Hello world 7 | CONSTANT: features { 8 | { global-hash? f } 9 | { required-classes { 10 | bignum byte-array copy-state fixnum object sequence tuple 11 | } } 12 | { quotation-compiler? f } 13 | { word-names? t } 14 | } 15 | 16 | ! We are lucky that the generics are inlined. 17 | : main-word ( -- ) 18 | "Hello, world!\n" 19 | >byte-array dup length stdout-handle fwrite 20 | stdout-handle fflush ; 21 | 22 | MAIN: main-word 23 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test03/test03.factor: -------------------------------------------------------------------------------- 1 | USING: examples.deploy.mini.features kernel math system ; 2 | IN: examples.deploy.mini.tests.test03 3 | 4 | ! 64-bit size: 14 280 (15 240) 5 | ! Purpose : Requiring the quotation compiler for generics 6 | CONSTANT: features 7 | { 8 | { quotation-compiler? t } 9 | { required-classes { fixnum } } 10 | { word-names? f } 11 | } 12 | 13 | GENERIC: b-length ( obj -- n ) 14 | 15 | TUPLE: tool-1 ; 16 | 17 | TUPLE: tool-2 ; 18 | 19 | M: fixnum b-length drop 3 ; 20 | 21 | M: tool-1 b-length drop 999 ; 22 | M: tool-2 b-length drop 998 ; 23 | 24 | : the-length ( n -- len ) 25 | b-length ; 26 | 27 | : main-word ( -- ) 28 | 3 the-length (exit) ; 29 | 30 | MAIN: main-word 31 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test04/test04.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: byte-arrays examples.deploy.mini.features kernel math sequences 4 | sequences.private slots.private system ; 5 | IN: examples.deploy.mini.tests.test04 6 | 7 | ! Purpose : Requiring additional classes for generics 8 | ! 64-bit size: 10 472 9 | CONSTANT: features { 10 | { quotation-compiler? t } 11 | { required-classes { 12 | bignum byte-array copy-state fixnum object sequence tuple 13 | } } 14 | { word-names? f } 15 | } 16 | 17 | : main-word ( -- ) 18 | "Hello, world!\n" >byte-array 1 slot (exit) ; 19 | 20 | MAIN: main-word 21 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test05/test05.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: byte-arrays examples.deploy.mini.features io.streams.c kernel 4 | math sequences sequences.private ; 5 | IN: examples.deploy.mini.tests.test05 6 | 7 | ! Purpose : Using io.streams.c:show 8 | ! 64-bit size: 70 088 (77 944) 9 | CONSTANT: features { 10 | { quotation-compiler? t } 11 | { required-classes { 12 | bignum byte-array copy-state fixnum object sequence tuple 13 | } } 14 | { word-names? t } 15 | } 16 | 17 | : main-word ( -- ) 18 | "Hello, world!" show ; 19 | 20 | MAIN: main-word 21 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test06/test06.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: byte-arrays examples.deploy.mini.features hashtables kernel 4 | math namespaces namespaces.private quotations sequences 5 | sequences.private system ; 6 | IN: examples.deploy.mini.tests.test06 7 | 8 | ! Purpose : Global variables 9 | ! 64-bit size: 72 408 10 | CONSTANT: features { 11 | { quotation-compiler? t } 12 | { required-classes { 13 | fixnum 14 | global-hashtable global-box 15 | hashtable 16 | object 17 | } } 18 | { global-hash? t } 19 | } 20 | 21 | : do-it ( -- ) 22 | 33 44 set-global ; 23 | 24 | : main-word ( -- ) 25 | do-it 44 get-global (exit) ; 26 | 27 | MAIN: main-word 28 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test07/test07.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: alien alien.strings byte-arrays examples.deploy.mini.features 4 | growable io.encodings io.encodings.utf8 io.streams.c io.streams.memory 5 | kernel kernel.private math quotations sbufs sequences 6 | sequences.private vectors ; 7 | IN: examples.deploy.mini.tests.test07 8 | 9 | ! Purpose : Reading special objects 10 | ! 64-bit size: 124 536 (135 656) 11 | CONSTANT: features { 12 | { quotation-compiler? t } 13 | { required-classes { 14 | bignum byte-array 15 | c-ptr compose copy-state curry 16 | decoder 17 | fixnum 18 | growable 19 | memory-stream 20 | object 21 | sequence 22 | sbuf 23 | tuple 24 | utf8 25 | } } 26 | { word-names? t } 27 | } 28 | 29 | : main-word ( -- ) 30 | OBJ-VM-COMPILER special-object>string show 31 | OBJ-VM-COMPILE-TIME special-object>string show ; 32 | 33 | MAIN: main-word 34 | -------------------------------------------------------------------------------- /examples/deploy/mini/tests/test08/test08.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2016 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: byte-arrays destructors examples.deploy.mini.features growable 4 | hash-sets hashtables io.streams.c kernel math namespaces 5 | namespaces.private quotations sequences sequences.private 6 | slots.private system ; 7 | IN: examples.deploy.mini.tests.test08 8 | 9 | ! Purpose : Preserving globals 10 | ! 64-bit size: (80 120) 11 | 12 | CONSTANT: features { 13 | { quotation-compiler? t } 14 | { required-classes { 15 | fixnum 16 | global-hashtable global-box 17 | hashtable 18 | object 19 | tuple 20 | } } 21 | { global-hash? t } 22 | { required-vars { os } } 23 | { word-names? t } 24 | } 25 | 26 | ! To prevent inlining trickery. 27 | : get-the-global ( key -- val ) 28 | get-global ; 29 | 30 | : main-word ( -- ) 31 | \ os get-the-global 2 slot 1 slot (exit) ; 32 | 33 | MAIN: main-word 34 | -------------------------------------------------------------------------------- /examples/deploy/mini/utils/utils.factor: -------------------------------------------------------------------------------- 1 | USING: byte-arrays formatting fry hashtables.private io io.streams.c 2 | kernel kernel.private macros math.private sequences sequences.private 3 | slots.private ; 4 | IN: examples.deploy.mini.utils 5 | 6 | : printff ( fmt -- ) 7 | sprintf print flush ; inline 8 | 9 | ! Generic-safe words. These should be used after generic stripping. 10 | 11 | MACRO: safe-show ( msg -- quot ) 12 | "\n" append >byte-array dup length '[ 13 | _ _ stdout-handle fwrite 14 | stdout-handle fflush 15 | ] ; 16 | 17 | : safe-first ( array -- first ) 18 | 0 swap array-nth ; 19 | 20 | : safe-second ( array -- first ) 21 | 1 swap array-nth ; 22 | 23 | : safe++ ( fixnum -- fixnum' ) 24 | 1 fixnum+fast ; 25 | 26 | : (safe-of) ( array key n -- val/f ) 27 | pick 1 slot dupd fixnum< [ 28 | ! array key n 29 | pick dupd 30 | ! array key n n array 31 | array-nth 32 | ! array key n elt 33 | pick over 34 | ! array key n elt key elt 35 | safe-first eq? [ 36 | 2nip nip safe-second 37 | ] [ 38 | drop safe++ (safe-of) 39 | ] if 40 | ] [ 41 | 3drop f 42 | ] if ; 43 | 44 | : safe-of ( array key -- val/f ) 45 | 0 (safe-of) ; 46 | 47 | : clear-specials ( start end -- ) 48 | 2dup fixnum> [ 2drop ] [ 49 | swap dup f swap set-special-object 50 | safe++ swap clear-specials 51 | ] if ; 52 | -------------------------------------------------------------------------------- /examples/deploy/mini/word-stripping/word-stripping.factor: -------------------------------------------------------------------------------- 1 | ! Copyright (C) 2015 Björn Lindqvist. 2 | ! See http://factorcode.org/license.txt for BSD license. 3 | USING: examples.deploy.mini.utils kernel memory quotations sequences 4 | slots.private words ; 5 | IN: examples.deploy.mini.word-stripping 6 | 7 | CONSTANT: SLOT-NAME 2 8 | CONSTANT: SLOT-VOCABULARY 3 9 | CONSTANT: SLOT-DEF 4 10 | CONSTANT: SLOT-PROPS 5 11 | CONSTANT: SLOT-PIC-DEF 6 12 | CONSTANT: SLOT-PIC-TAIL-DEF 6 13 | 14 | : clear-slot ( word n -- ) 15 | f -rot set-slot ; 16 | 17 | : strip-word ( word-names? word -- ) 18 | swap [ 19 | dup SLOT-NAME clear-slot 20 | dup SLOT-VOCABULARY clear-slot 21 | ] unless 22 | dup SLOT-PROPS clear-slot 23 | dup SLOT-PIC-DEF slot [ jit-compile ] when* 24 | dup SLOT-PIC-TAIL-DEF slot [ jit-compile ] when* 25 | SLOT-DEF clear-slot ; 26 | 27 | : strip-words ( word-names? -- ) 28 | "Compiling identity quotation..." safe-show 29 | [ ] dup jit-compile f swap 1 set-slot 30 | 31 | "Stripping word instances..." safe-show 32 | all-instances [ 33 | dup word? [ strip-word ] [ 2drop ] if 34 | ] with each ; 35 | -------------------------------------------------------------------------------- /examples/deploy/small/small.factor: -------------------------------------------------------------------------------- 1 | USING: accessors kernel kernel.private 2 | math.ranges memory quotations sequences slots.private system words ; 3 | IN: examples.deploy.small 4 | 5 | : main-word ( -- ) 99 (exit) ; 6 | 7 | : clear-specials ( start end -- ) 8 | [a,b] [ f swap set-special-object ] each ; 9 | 10 | : strip-word ( id-quot word -- ) 11 | f >>props f >>name f >>vocabulary def<< ; 12 | 13 | : small-image ( -- ) 14 | ! Stripped and pre-compiled identity quot. 15 | [ ] dup jit-compile dup f swap 1 set-slot 16 | 17 | [ word? ] instances [ strip-word ] with each 18 | 19 | ! Can't get rid of c-to-factor primitive because it's tied to a 20 | ! callback. 21 | f C-TO-FACTOR-WORD special-object 8 set-slot 22 | \ main-word 9 slot C-TO-FACTOR-WORD special-object 9 set-slot 23 | \ main-word C-TO-FACTOR-WORD set-special-object 24 | 25 | ! Startup quot, global and shutdown quot 26 | OBJ-STARTUP-QUOT OBJ-SHUTDOWN-QUOT clear-specials 27 | 28 | ! JIT removal, must be done almost last. 29 | JIT-PROLOG JIT-DECLARE-WORD clear-specials 30 | 31 | ! Entry points and signal handlers we can do without 32 | LAZY-JIT-COMPILE-WORD REDEFINITION-COUNTER clear-specials 33 | 34 | ! PIC things, megamorphic caches, undefined and stderr 35 | PIC-LOAD OBJ-STDERR clear-specials 36 | "whatever.image" save-image-and-exit ; 37 | 38 | MAIN: small-image 39 | -------------------------------------------------------------------------------- /examples/files/tail/tail.factor: -------------------------------------------------------------------------------- 1 | USING: accessors io io.encodings.utf8 io.files io.monitors kernel namespaces ; 2 | IN: examples.files.tail 3 | 4 | : emit-changes ( monitor -- ) 5 | dup next-change drop 6 | input-stream get output-stream get stream-copy* flush 7 | emit-changes ; 8 | 9 | : seek-input-end ( -- ) 10 | 0 seek-end input-stream get stream>> stream-seek ; 11 | 12 | : tail-file ( fname -- ) 13 | [ 14 | dup f [ 15 | swap utf8 [ 16 | seek-input-end emit-changes 17 | ] with-file-reader 18 | ] with-monitor 19 | ] with-monitors ; 20 | -------------------------------------------------------------------------------- /examples/functors/functors.factor: -------------------------------------------------------------------------------- 1 | USING: functors io lexer namespaces ; 2 | IN: examples.functors 3 | 4 | FUNCTOR: define-table ( NAME -- ) 5 | 6 | name-datasource DEFINES-CLASS ${NAME}-datasource 7 | 8 | clear-name DEFINES clear-${NAME} 9 | init-name DEFINES init-${NAME} 10 | 11 | WHERE 12 | 13 | SINGLETON: name-datasource 14 | 15 | : clear-name ( -- ) "clear table code here" print ; 16 | 17 | : init-name ( -- ) "init table code here" print ; 18 | 19 | name-datasource [ "hello-hello" ] initialize 20 | 21 | ;FUNCTOR 22 | 23 | SYNTAX: SQL-TABLE: 24 | scan-token define-table ; 25 | -------------------------------------------------------------------------------- /examples/golf/all-roads/all-roads.factor: -------------------------------------------------------------------------------- 1 | USING: accessors html.parser.analyzer io kernel math namespaces 2 | present regexp sequences ; 3 | 4 | IN: examples.golf.all-roads 5 | 6 | SYMBOL: G 7 | 8 | : match-good-pages ( a -- ?/f ) 9 | R/ \/wiki\/[^:]*$/ first-match ; 10 | 11 | : filter-urls ( tags -- urls ) 12 | find-hrefs [ present ] map 13 | [ match-good-pages ] filter 14 | [ match-good-pages seq>> ] map ; 15 | 16 | : page-title ( seq -- title ) 17 | dup "title" find-by-name drop 1 + swap nth 18 | text>> R/ - Wikipedia,/ re-split first ; 19 | 20 | : page-links ( seq -- links ) 21 | "bodyContent" find-by-id-between filter-urls ; 22 | 23 | : scrape-en-wiki-url ( wiki-url -- seq ) 24 | "https://en.wikipedia.org" prepend 25 | dup print flush scrape-html nip ; 26 | 27 | : found-url? ( wiki-url -- ? ) 28 | G get [ = ] [ drop t ] if* ; 29 | 30 | : findpath ( wiki-url -- seq/f ) 31 | dup found-url? 32 | [ drop f G set f ] [ 33 | scrape-en-wiki-url 34 | [ page-title print flush ] [ 35 | page-links [ findpath ] map 36 | ] bi 37 | ] if ; inline recursive 38 | -------------------------------------------------------------------------------- /examples/golf/challenge-252/challenge-252-tests.factor: -------------------------------------------------------------------------------- 1 | USING: examples.golf.challenge-252 sequences tools.test ; 2 | IN: examples.golf.challenge-252.tests 3 | 4 | : big-input ( -- str ) 5 | "hpevfwqjmjryhemuqjoiatpjmddxdjwzskdcfgdtbmkbcxrnmjuoyddnqwluimjwvguxehszxzvbmufq 6 | lrepncxxbrrzxnzmkoyhrjcstvfazyhrhgssximjdfcmdjusylfkwbedyrsxovrmvjzaljfjmywpfnjg 7 | isoqbdyspgzlcmdjmhbpxhzvvhckidzuwzkauffsujmcrhvgeqvasjakgtzlxkthjqwxypmsovjbfshr 8 | rxtdvkmbyhejoeydnrdowuwhgmbvxmpixyttglsjgmcoqbberssfjraaqfrkmebsozsjfnubhktbbai_ 9 | vxbifbofyednnutmxtisvfsktbqfijfzdjoqybuohtztysqelaqyixyaiolbgwylwfisfwubivuoablx 10 | smrqggedwyiqvseevwbcxcfjttdbweedcjgnsorizflsjtmltcoaynsrsupavqwcyzhgiplwkohlhrai 11 | nazaacvuqblpbzimgoxirejbshnbmdtgsbvlhpnugggencjaczqqiwixrwiyobmlkbwdlwcioqmjhoac 12 | dvcqdypxeichmgywocbcafumthdqrbjnpgnnmaasxiaxxfymcyiuqduztqneodstbcnjpeebgxgosoyd 13 | vpzlqjuroebbehafsemanwprhwkircuhlgcftqsjdusrqetbthxclfokpdlspxzuvhxpbeqqbfpqffsg 14 | yilqltfxrmtimcugytazkerhcfnirtavcnmfdyictlncwttkmxyfhgejygfefqrjknuqsfldmjmwjdfq 15 | sicfrzbfazchdgznekwmhridelcejnkmcgmpgtihbwmplrtrrefoyhyzxpjjlkabbbgspeokzhpjxsvp 16 | fjmdsoripvfrgyzxodoeirwwdaofdmwqrqyvdijlfqyzfspdoyrhewxbpufdqcpqdolkmrnvedixzpfd 17 | akggkslxcrjbrmnynviihbkzaqqffkkcgwjbettexhlwlasdfjnslwsmnclhafvebxxfdozsjtdvobik 18 | rrsuysujwliobagobxmlyxjeltwzwxpyrnkdxfemotfncyriaycyfemygjmpboocgtsvttqntegvleyn 19 | wgpjhyyysbltoxljsascsngbgfqmpzgpejzlmdkjzzlfxvagyrasmpzqntgqsvyqjugkhbrbkiqewlyf 20 | tvsq_______znp_____xkwt______wef______tz______kfc_______ha_______pn__lmg__iakrbt 21 | iyfi__uojrxvx__tps__fp__pfpndbi__ggpalde__wmd__kn__ifiadob__hdljdbd__zl__whlwilt 22 | bcmt__haagmjg__dwx__oh__utnzudq__xstxxyc__vly__mr__viilzav__swosyvc__i__hnaqxyev 23 | jykc__wyfoyir__ewp__ij__mrdavxl__tcdtxqy__fnr__cf__mrkepwj__djhrsau____lhefqxgmu 24 | zdgf______tjg__fip__mi__b____xc__vjvhpqy______vff_____wuup_____kqct___htiggvvpet 25 | yvco__pqbrlox__ayj__af__dnn__kx__mlitytx____jauna__kncmiym__dlwushk____gjptzccgc 26 | nntt__hfqyxzi__eqn__vz__hlh__we__dtfkfvf__g__litm__zeqjtdl__bkdapxs__o__oxeouwer 27 | bfjr__ipcqmop__kec__ip__icc__ci__vpxxueu__eq__sau__nhheydy__efqkdgq__us__pzlndhk 28 | hdmk__cmfvzwcb_____xdka______trj______yj__xpi__he_______nb_______by__rrn__tvxvig 29 | jfpseyjjbrrtsfnmbrokdqtfzhhdtbhtvpiyshmvcqaypfxcvbgvbvwrkanjfcsjnanmktkwimnvynuk 30 | cmgtqmovkrdmfuduqvbqydagsttictcnsrhfrpoebcehdzhjamykqpjtktufcvokljjijjsrivyhxtgw 31 | ojgoujyhmekzsoczwlqnruwcuhudgfaijzrkewzgjvorsmabpcdmurctwjrddcnkmfvabjwlbqssihdy 32 | bgfqchqdvjcsdllrlwmyikuvthguzfbgocaeqktvbcapzdcfjphqnhundtljqjeyfrkjspfvghqddxwx 33 | idtjjkctrkfcjmdpqyvavqbntpmkkuswfgbgalrysjfnzezjjscahoodjjelavydefzjmhsqfufsexlv 34 | vzziymsyqrcvhsrxjnysioswvjlqdbnwgyjlanmhzkbygkptycdoifsibytbrixggjeiepaybzxhvfsy 35 | ayeptgpxbhhfkkpromhjykfxnujorlzcmkcmvvgmveyfkgiwgosznfpmbhixsakxfkuxhwcgularehpa 36 | guquulrjllxmkfzgnchrxzcfdklytpfnezergkwkhgalqlvdhkdgulgfaxtybqttcjtlgmfwaymaxlwa 37 | spyrboibwkzzbtgigyswbtpwxgphcmkfpmvbfjimnxctinqssshofhlvlpqcwiuacjyxyqmvaibezofv 38 | atyhpqvjubgcwqeoytloypjphoxeimumuvswxkgamodoxiciwmgxvsenkgdhttzlenjbszrksopicjcj 39 | nvsosrapkfilwsaoptdavlfglioqpwoqskbgikksnnuzvmxyrtrbjouvgokxgbnwxnivtykvhjkaydsk 40 | zoowbhjrlojgeecdoggqqtomcdgrjzmlkhubyaewwtrlyutsptdrrigopueicoganyasrjeaiivzairu 41 | lklovyrpckwpowprxtvhaeivpudfchxbwvtosmivpcsesbzpsynxitlisuifuehceonjeydljzuzpsgj 42 | llcywoxbblitscquxiykcjxhsgkbhfhfrshsrpyrcaetahuwbeybvlvkthxydkapxlfikdwudjkmjjsa 43 | zajxpuikiqwsifhldfovqoycwmtlmcaycirhcehxnpfadrgyaogpcmomcgtmacnvbwfnimaqqvxijcbp 44 | mckwimloiinindfuakqjmpyjisxnbybtywhymnkdoyiphijzelmrazplgfcmcsjiovxqdxmuqulzklgx" ; 45 | 46 | { 47 | { 3 1 4 CHAR: b } 48 | { 2 1 3 CHAR: - } 49 | f 50 | f 51 | } [ 52 | "abcbba" widest-leftmost-pair 53 | "x-----------x" widest-leftmost-pair 54 | "" widest-leftmost-pair 55 | "e" widest-leftmost-pair 56 | ] unit-test 57 | 58 | { 59 | { 10 36 46 CHAR: y } 60 | { 17 92 109 CHAR: z } 61 | } [ 62 | "ttvmswxjzdgzqxotby_lslonwqaipchgqdo_yz_fqdagixyrobdjtnl_jqzpptzfcdcjjcpjjnnvopmh" 63 | widest-leftmost-pair 64 | big-input widest-leftmost-pair 65 | ] unit-test 66 | 67 | { "acbab" } [ 68 | "abcbba" { 3 1 4 CHAR: b } update-string 69 | ] unit-test 70 | 71 | { { "cab" "rainbow" } } [ 72 | { 73 | "abcbba" 74 | "ttvmswxjzdgzqxotby_lslonwqaipchgqdo_yz_fqdagixyrobdjtnl_jqzpptzfcdcjjcpjjnnvopmh" 75 | } [ decode ] map 76 | ] unit-test 77 | 78 | { "dragon" } [ 79 | big-input decode 80 | ] unit-test 81 | -------------------------------------------------------------------------------- /examples/golf/challenge-252/challenge-252.factor: -------------------------------------------------------------------------------- 1 | USING: arrays assocs fry kernel locals math sequences splitting ; 2 | IN: examples.golf.challenge-252 3 | 4 | :: refine-index ( max-i index prev-index -- ) 5 | index keys [ [ prev-index at ] [ index set-at ] bi ] each 6 | index [ nip max-i >= ] assoc-filter! drop ; 7 | 8 | ! Pair is either passed through unchanged, or if we find a better 9 | ! match, it is narrowed. 10 | :: update-pair ( pair ch i index prev-index -- pair' ) 11 | index ch of :> char-i 12 | pair 13 | char-i [ 14 | i char-i - pair first > [ 15 | drop i char-i - char-i i ch 4array 16 | ] when 17 | prev-index ch of index prev-index refine-index 18 | ] [ i ch index set-at ] if 19 | i ch prev-index set-at ; 20 | 21 | : widest-leftmost-pair ( str -- pair/f ) 22 | { 0 0 0 f } swap 23 | H{ } clone H{ } clone '[ _ _ update-pair ] each-index 24 | dup last [ drop f ] unless ; 25 | 26 | : update-string ( str pair -- str' ) 27 | [ [ second ] [ third ] bi rot remove-nth remove-nth ] 28 | [ second swap nth ] 2bi suffix ; 29 | 30 | : (decode) ( str -- str' ) 31 | dup widest-leftmost-pair [ update-string (decode) ] when* ; 32 | 33 | : decode ( str -- str' ) 34 | "\n" "" replace (decode) "_" split first ; 35 | -------------------------------------------------------------------------------- /examples/golf/wordcheck/bits.dat: -------------------------------------------------------------------------------- 1 | 2583862695582757354612767613075215973831882379321462955907023187061600134993413205548028190785077706599157974966353348650163481694154780459852106223617344846926846315362711610959265430673197267785057152019105464978675984717474912264821709846325707900914798058832215696430799330592843205746475565391338862562766882203283446857549263417108889537326653108596293823588744674644504540301833874295547262875385660770057491548560869048422088110889920664971656179474576989785597426528831767979632855750218538484155445456116208397830517556961937959226155641265164828976465485040435245952475798829426334792145747095884911997939014195525906035951424017392089001460832683753151073074321264473449125124185131702880956493247147939721743467902177447352327801954821486894330112153161972500777638630229696763209578258438337602460487292560725304289939344827202598501693735568323218988724362344202060253992865376623543034329624555875214047932098564949087986691853324009594474239502967901865793482077673715725767832332760520047400479681929506088042287626075909071188808071872722556613947182630440518008441368441388268533342115795192703366574809979891528876830088945461480656744660587314653840406100616852356096366075596023739677726339874312781804011023238881113034165555941926014029828484909153491325490390668457636022344666199707069558705581411408002853841764974669171551900675253338911581443774245304088895670782150417435718974641961510848215882325546727133213063626525716111313045927493387887583399924895554410561972708315708954655524137981767038809176013531939822533192489847758591325064745176190625384089775779165747272713251458739322360607814140556906554685004667444875583511615931990089226312682084100578012669957371553291604304927029349101378658525217626746361405370741403196495142487851405807274546229867872146366724431387784008042467755902244548324824950707364068983009869093946453189991721413622233493017777703226720245423274178090850347068286643003304544072764328044810037014411213956313834217882257372384173711657569139676394250189861778359143394275631859985957171736329805058966375674858376904731527543999113537956110659650572766834249312131979043878052546004541510437589347459904812503090154329547323692647693768441199638308905712410474566347158678880002009420388379868695679909141992266202499504695968095338524832474039179837092875651848316091827089508093779694735524269805793386551858048349951362396085589797389379204532984303880822631847707706245350455518176056035087256997764619384242527045577472497212721806632385541245131556228708193383788462189845171291258390827257904940615897682688575387309356316807556347523087289826454121294347509318706318503627273836938461571287891036826749705955871217269061557143888049761931416601017181434330858920806058085878402060734843150773704148991962019324281029112412449205927042800350534840257226738831204216155355195585607242772028830320001857678280985 2 | -------------------------------------------------------------------------------- /examples/golf/wordcheck/wordcheck-build.factor: -------------------------------------------------------------------------------- 1 | USING: accessors base64 bit-arrays bloom-filters fry io.encodings.utf8 2 | io.files kernel sequences strings ; 3 | IN: examples.golf.wordcheck 4 | 5 | : dictionary-words ( file -- seq ) 6 | utf8 file-lines "I" swap remove ; 7 | 8 | : setup-bloom-filter ( words err cap -- filter ) 9 | [ '[ _ bloom-filter-insert ] each ] keep ; 10 | 11 | : serialization-values ( filter -- #hashes len str count ) 12 | [ #hashes>> ] 13 | [ bits>> [ length ] [ underlying>> >base64 >string ] bi ] 14 | [ count>> ] tri ; 15 | -------------------------------------------------------------------------------- /examples/golf/wordcheck/wordcheck.factor: -------------------------------------------------------------------------------- 1 | USING: ascii base64 bit-arrays bloom-filters io kernel sequences system ; 2 | IN: examples.golf.wordcheck 3 | 4 | CONSTANT: S "iAlOYCCAE2MARMNA4ICNzwABZAbwhAeGBMIYgDsYAAwIgoQFB/ADCBwX4IrgAOHA/g7YAYiAYaEBgEINgMGZAeGIJI0AwAqePxzLhi7HYgMaY8PLMQAKIOAPMAC7xoEB4AA6+J+zAOAAzxhDBEwaAAYQbHEYYA8YIMFw0DIaDHhA2H4RMAkYAgACGjOCD2Dmwwy2YuDSdMcCZQAkwJ4siYMPFxjQfN0MMIwDPgIBDBDvGSY4M4IAIjYOgoyMxwCOujfje5AL7KFwfGEAiIPBOAABsIDDAR8gBgAjgEUAPng+71kCJoAdBiZw+zA4gAAaILANEBxwg5eBMEZqeAYwC53BgBlYaoMBMAlAUMCgeeD2gQ4rAK7gQce4D/BmEJhfAR48D8QKMxk2CMSP8ObTAHmcB8aemAEyDiOjAJhhwLvGAJhvP7zwgY4D6Ms2cx/A4KcAjgOzY8SbzMFgN+AU1Hwwhjd3MyD3wcNjBGAY3OEZgHAA/AbvfwI3NiEQAoCDOOjRMDP4IGH2EYUoD27ygAd44AyA9+2z33jXDMRAG2xiAQBgDsALgG0O+dgAfwMIXJZHMPKolod/68CJh+HDwNAcwTEGgCci29hsdCAA2IESQPCYg+AcAIABmB3MwAfHIL8v5gSw5vtmEACeA8CQyMc77DzaZmDh/Q/ceEDCHTwA5gPyAAOgAJsPA4GDt2sNt9ULYBb9TRhigJ1OGAA2YOE6/xuzIAA5AhA8wB9swAKA4Abd+Qfwe0C8c+Gmf+QAcX4AQwYwM2A2zgAD/koLsOOAAcIgMA5sO8AC9xN+/AkYAA7UWVCG+QPwwAW8eQEcAMB++H15EBAS0A6/gQHD5QBghkEGkAEQez9i3gP9BB4ZxzABKl48mOANgAcMaPMh4EkI0HgeWBje3zbwQAcAHWaZQS5wgM8HDAIFxBiBn/MGbPMCwzATX+AwQdnECAMQEFgYwuA5xjAAoAAs3AzkGMDPA2MYHtownIGBGU5w0AQAMGAGDBADDgEs0AEzXB6ARGzDgXE4gkaejd2REQ==" 5 | 6 | : F ( -- f ) 7 | 4 S base64> 6247 swap bit-array boa 1000 996 bloom-filter boa ; 8 | 9 | readln 1 cut swap >lower prepend 10 | dup "I" = [ drop t ] [ F bloom-filter-member? ] if 11 | 1 0 ? exit 12 | -------------------------------------------------------------------------------- /examples/golf/wordcheck/words.dat: -------------------------------------------------------------------------------- 1 | a 2 | about 3 | above 4 | across 5 | act 6 | active 7 | activity 8 | add 9 | afraid 10 | after 11 | again 12 | age 13 | ago 14 | agree 15 | air 16 | all 17 | alone 18 | along 19 | already 20 | always 21 | am 22 | amount 23 | an 24 | and 25 | angry 26 | another 27 | answer 28 | any 29 | anyone 30 | anything 31 | anytime 32 | appear 33 | apple 34 | are 35 | area 36 | arm 37 | army 38 | around 39 | arrive 40 | art 41 | as 42 | ask 43 | at 44 | attack 45 | aunt 46 | autumn 47 | away 48 | baby 49 | back 50 | bad 51 | bag 52 | ball 53 | bank 54 | base 55 | basket 56 | bath 57 | be 58 | bean 59 | bear 60 | beautiful 61 | bed 62 | bedroom 63 | beer 64 | before 65 | begin 66 | behave 67 | behind 68 | bell 69 | below 70 | besides 71 | best 72 | better 73 | between 74 | big 75 | bird 76 | birth 77 | birthday 78 | bit 79 | bite 80 | black 81 | bleed 82 | block 83 | blood 84 | blow 85 | blue 86 | board 87 | boat 88 | body 89 | boil 90 | bone 91 | book 92 | border 93 | born 94 | borrow 95 | both 96 | bottle 97 | bottom 98 | bowl 99 | box 100 | boy 101 | branch 102 | brave 103 | bread 104 | break 105 | breakfast 106 | breathe 107 | bridge 108 | bright 109 | bring 110 | brother 111 | brown 112 | brush 113 | build 114 | burn 115 | bus 116 | business 117 | busy 118 | but 119 | buy 120 | by 121 | cake 122 | call 123 | can 124 | candle 125 | cap 126 | car 127 | card 128 | care 129 | careful 130 | careless 131 | carry 132 | case 133 | cat 134 | catch 135 | central 136 | century 137 | certain 138 | chair 139 | chance 140 | change 141 | chase 142 | cheap 143 | cheese 144 | chicken 145 | child 146 | children 147 | chocolate 148 | choice 149 | choose 150 | circle 151 | city 152 | class 153 | clean 154 | clear 155 | clever 156 | climb 157 | clock 158 | close 159 | cloth 160 | clothes 161 | cloud 162 | cloudy 163 | coat 164 | coffee 165 | coin 166 | cold 167 | collect 168 | colour 169 | comb 170 | come 171 | comfortable 172 | common 173 | compare 174 | complete 175 | computer 176 | condition 177 | contain 178 | continue 179 | control 180 | cook 181 | cool 182 | copper 183 | corn 184 | corner 185 | correct 186 | cost 187 | count 188 | country 189 | course 190 | cover 191 | crash 192 | cross 193 | cry 194 | cup 195 | cupboard 196 | cut 197 | dance 198 | dangerous 199 | dark 200 | daughter 201 | day 202 | dead 203 | decide 204 | decrease 205 | deep 206 | deer 207 | depend 208 | desk 209 | destroy 210 | develop 211 | die 212 | different 213 | difficult 214 | dinner 215 | direction 216 | dirty 217 | discover 218 | dish 219 | do 220 | dog 221 | door 222 | double 223 | down 224 | draw 225 | dream 226 | dress 227 | drink 228 | drive 229 | drop 230 | dry 231 | duck 232 | dust 233 | duty 234 | each 235 | ear 236 | early 237 | earn 238 | earth 239 | east 240 | easy 241 | eat 242 | education 243 | effect 244 | egg 245 | eight 246 | either 247 | electric 248 | elephant 249 | else 250 | empty 251 | end 252 | enemy 253 | enjoy 254 | enough 255 | enter 256 | entrance 257 | equal 258 | escape 259 | even 260 | evening 261 | event 262 | ever 263 | every 264 | everybody 265 | everyone 266 | exact 267 | examination 268 | example 269 | except 270 | excited 271 | exercise 272 | expect 273 | expensive 274 | explain 275 | extremely 276 | eye 277 | face 278 | fact 279 | fail 280 | fall 281 | false 282 | family 283 | famous 284 | far 285 | farm 286 | fast 287 | fat 288 | father 289 | fault 290 | fear 291 | feed 292 | feel 293 | female 294 | fever 295 | few 296 | fight 297 | fill 298 | film 299 | find 300 | fine 301 | finger 302 | finish 303 | fire 304 | first 305 | fit 306 | five 307 | fix 308 | flag 309 | flat 310 | float 311 | floor 312 | flour 313 | flower 314 | fly 315 | fold 316 | food 317 | fool 318 | foot 319 | football 320 | for 321 | force 322 | foreign 323 | forest 324 | forget 325 | forgive 326 | fork 327 | form 328 | four 329 | fox 330 | free 331 | freedom 332 | freeze 333 | fresh 334 | friend 335 | friendly 336 | from 337 | front 338 | fruit 339 | full 340 | fun 341 | funny 342 | furniture 343 | further 344 | future 345 | game 346 | garden 347 | gate 348 | general 349 | gentleman 350 | get 351 | gift 352 | give 353 | glad 354 | glass 355 | go 356 | goat 357 | god 358 | gold 359 | good 360 | goodbye 361 | grandfather 362 | grandmother 363 | grass 364 | grave 365 | great 366 | green 367 | grey 368 | ground 369 | group 370 | grow 371 | gun 372 | hair 373 | half 374 | hall 375 | hammer 376 | hand 377 | happen 378 | happy 379 | hard 380 | hat 381 | hate 382 | have 383 | he 384 | head 385 | healthy 386 | hear 387 | heart 388 | heaven 389 | heavy 390 | height 391 | hello 392 | help 393 | hen 394 | her 395 | here 396 | hers 397 | hide 398 | high 399 | hill 400 | him 401 | his 402 | hit 403 | hobby 404 | hold 405 | hole 406 | holiday 407 | home 408 | hope 409 | horse 410 | hospital 411 | hot 412 | hotel 413 | hour 414 | house 415 | how 416 | hundred 417 | hungry 418 | hurry 419 | hurt 420 | husband 421 | I 422 | ice 423 | idea 424 | if 425 | important 426 | in 427 | increase 428 | inside 429 | into 430 | introduce 431 | invent 432 | invite 433 | iron 434 | is 435 | island 436 | it 437 | its 438 | jelly 439 | job 440 | join 441 | juice 442 | jump 443 | just 444 | keep 445 | key 446 | kill 447 | kind 448 | king 449 | kitchen 450 | knee 451 | knife 452 | knock 453 | know 454 | ladder 455 | lady 456 | lamp 457 | land 458 | large 459 | last 460 | late 461 | lately 462 | laugh 463 | lazy 464 | lead 465 | leaf 466 | learn 467 | leave 468 | left 469 | leg 470 | lend 471 | length 472 | less 473 | lesson 474 | let 475 | letter 476 | library 477 | lie 478 | life 479 | light 480 | like 481 | lion 482 | lip 483 | list 484 | listen 485 | little 486 | live 487 | lock 488 | lonely 489 | long 490 | look 491 | lose 492 | lot 493 | love 494 | low 495 | lower 496 | luck 497 | machine 498 | main 499 | make 500 | male 501 | man 502 | many 503 | map 504 | mark 505 | market 506 | marry 507 | matter 508 | may 509 | me 510 | meal 511 | mean 512 | measure 513 | meat 514 | medicine 515 | meet 516 | member 517 | mention 518 | method 519 | middle 520 | milk 521 | million 522 | mind 523 | minute 524 | miss 525 | mistake 526 | mix 527 | model 528 | modern 529 | moment 530 | money 531 | monkey 532 | month 533 | moon 534 | more 535 | morning 536 | most 537 | mother 538 | mountain 539 | mouth 540 | move 541 | much 542 | music 543 | must 544 | my 545 | name 546 | narrow 547 | nation 548 | nature 549 | near 550 | nearly 551 | neck 552 | need 553 | needle 554 | neighbour 555 | neither 556 | net 557 | never 558 | new 559 | news 560 | newspaper 561 | next 562 | nice 563 | night 564 | nine 565 | no 566 | noble 567 | noise 568 | none 569 | nor 570 | north 571 | nose 572 | not 573 | nothing 574 | notice 575 | now 576 | number 577 | obey 578 | object 579 | ocean 580 | of 581 | off 582 | offer 583 | office 584 | often 585 | oil 586 | old 587 | on 588 | one 589 | only 590 | open 591 | opposite 592 | or 593 | orange 594 | order 595 | other 596 | our 597 | out 598 | outside 599 | over 600 | own 601 | page 602 | pain 603 | paint 604 | pair 605 | pan 606 | paper 607 | parent 608 | park 609 | part 610 | partner 611 | party 612 | pass 613 | past 614 | path 615 | pay 616 | peace 617 | pen 618 | pencil 619 | people 620 | pepper 621 | per 622 | perfect 623 | period 624 | person 625 | petrol 626 | photograph 627 | piano 628 | pick 629 | picture 630 | piece 631 | pig 632 | pin 633 | pink 634 | place 635 | plane 636 | plant 637 | plastic 638 | plate 639 | play 640 | please 641 | pleased 642 | plenty 643 | pocket 644 | point 645 | poison 646 | police 647 | polite 648 | pool 649 | poor 650 | popular 651 | position 652 | possible 653 | potato 654 | pour 655 | power 656 | present 657 | press 658 | pretty 659 | prevent 660 | price 661 | prince 662 | prison 663 | private 664 | prize 665 | probably 666 | problem 667 | produce 668 | promise 669 | proper 670 | protect 671 | provide 672 | public 673 | pull 674 | punish 675 | pupil 676 | push 677 | put 678 | queen 679 | question 680 | quick 681 | quiet 682 | quite 683 | radio 684 | rain 685 | rainy 686 | raise 687 | reach 688 | read 689 | ready 690 | real 691 | really 692 | receive 693 | record 694 | red 695 | remember 696 | remind 697 | remove 698 | rent 699 | repair 700 | repeat 701 | reply 702 | report 703 | rest 704 | restaurant 705 | result 706 | return 707 | rice 708 | rich 709 | ride 710 | right 711 | ring 712 | rise 713 | road 714 | rob 715 | rock 716 | room 717 | round 718 | rubber 719 | rude 720 | rule 721 | ruler 722 | run 723 | rush 724 | sad 725 | safe 726 | sail 727 | salt 728 | same 729 | sand 730 | save 731 | say 732 | school 733 | science 734 | scissors 735 | search 736 | seat 737 | second 738 | see 739 | seem 740 | sell 741 | send 742 | sentence 743 | serve 744 | seven 745 | several 746 | sex 747 | shade 748 | shadow 749 | shake 750 | shape 751 | share 752 | sharp 753 | she 754 | sheep 755 | sheet 756 | shelf 757 | shine 758 | ship 759 | shirt 760 | shoe 761 | shoot 762 | shop 763 | short 764 | should 765 | shoulder 766 | shout 767 | show 768 | sick 769 | side 770 | signal 771 | silence 772 | silly 773 | silver 774 | similar 775 | simple 776 | since 777 | sing 778 | single 779 | sink 780 | sister 781 | sit 782 | six 783 | size 784 | skill 785 | skin 786 | skirt 787 | sky 788 | sleep 789 | slip 790 | slow 791 | small 792 | smell 793 | smile 794 | smoke 795 | snow 796 | so 797 | soap 798 | sock 799 | soft 800 | some 801 | someone 802 | something 803 | sometimes 804 | son 805 | soon 806 | sorry 807 | sound 808 | soup 809 | south 810 | space 811 | speak 812 | special 813 | speed 814 | spell 815 | spend 816 | spoon 817 | sport 818 | spread 819 | spring 820 | square 821 | stamp 822 | stand 823 | star 824 | start 825 | station 826 | stay 827 | steal 828 | steam 829 | step 830 | still 831 | stomach 832 | stone 833 | stop 834 | store 835 | storm 836 | story 837 | strange 838 | street 839 | strong 840 | structure 841 | student 842 | study 843 | stupid 844 | subject 845 | substance 846 | successful 847 | such 848 | sudden 849 | sugar 850 | suitable 851 | summer 852 | sun 853 | sunny 854 | support 855 | sure 856 | surprise 857 | sweet 858 | swim 859 | sword 860 | table 861 | take 862 | talk 863 | tall 864 | taste 865 | taxi 866 | tea 867 | teach 868 | team 869 | tear 870 | telephone 871 | television 872 | tell 873 | ten 874 | tennis 875 | terrible 876 | test 877 | than 878 | that 879 | the 880 | their 881 | then 882 | there 883 | therefore 884 | these 885 | thick 886 | thin 887 | thing 888 | think 889 | third 890 | this 891 | though 892 | threat 893 | three 894 | tidy 895 | tie 896 | title 897 | to 898 | today 899 | toe 900 | together 901 | tomorrow 902 | tonight 903 | too 904 | tool 905 | tooth 906 | top 907 | total 908 | touch 909 | town 910 | train 911 | tram 912 | travel 913 | tree 914 | trouble 915 | true 916 | trust 917 | try 918 | turn 919 | twice 920 | type 921 | uncle 922 | under 923 | understand 924 | unit 925 | until 926 | up 927 | use 928 | useful 929 | usual 930 | usually 931 | vegetable 932 | very 933 | village 934 | visit 935 | voice 936 | wait 937 | wake 938 | walk 939 | want 940 | warm 941 | wash 942 | waste 943 | watch 944 | water 945 | way 946 | we 947 | weak 948 | wear 949 | weather 950 | wedding 951 | week 952 | weight 953 | welcome 954 | well 955 | west 956 | wet 957 | what 958 | wheel 959 | when 960 | where 961 | which 962 | while 963 | white 964 | who 965 | why 966 | wide 967 | wife 968 | wild 969 | will 970 | win 971 | wind 972 | window 973 | wine 974 | winter 975 | wire 976 | wise 977 | wish 978 | with 979 | without 980 | woman 981 | wonder 982 | word 983 | work 984 | world 985 | worry 986 | worst 987 | write 988 | wrong 989 | year 990 | yes 991 | yesterday 992 | yet 993 | you 994 | young 995 | your 996 | zero 997 | zoo -------------------------------------------------------------------------------- /examples/images/drawing/drawing.factor: -------------------------------------------------------------------------------- 1 | USING: accessors cairo cairo.ffi combinators images images.loader 2 | io.files.temp kernel sequences ; 3 | IN: examples.images.drawing 4 | 5 | : draw-stuff ( cr -- ) 6 | { 7 | [ 5 cairo_set_line_width ] 8 | [ 1.0 0.0 0.0 cairo_set_source_rgb ] 9 | [ 10 10 220 100 cairo_rectangle ] 10 | [ cairo_stroke ] 11 | [ 12 | "serif" 13 | CAIRO_FONT_SLANT_NORMAL 14 | CAIRO_FONT_WEIGHT_NORMAL 15 | cairo_select_font_face 16 | ] 17 | [ 32.0 cairo_set_font_size ] 18 | [ 0.0 0.0 1.0 cairo_set_source_rgb ] 19 | [ 20.0 50.0 cairo_move_to ] 20 | [ "Hello, Cairo!" cairo_show_text ] 21 | } cleave ; 22 | 23 | : save-cairo-image ( -- ) 24 | { 240 120 } [ draw-stuff ] make-bitmap-image 25 | "cairo-image.png" temp-file save-graphic-image ; 26 | -------------------------------------------------------------------------------- /examples/images/resizing/resizing.factor: -------------------------------------------------------------------------------- 1 | USING: accessors cairo cairo.ffi combinators images kernel math 2 | math.functions math.vectors sequences ; 3 | IN: examples.images.resizing 4 | 5 | : image>cairo-surface ( image -- surface ) 6 | [ bitmap>> CAIRO_FORMAT_ARGB32 ] 7 | [ dim>> first2 ] 8 | [ rowstride ] tri 9 | cairo_image_surface_create_for_data ; 10 | 11 | : scale-size ( size scale -- size' ) 12 | v* [ round >integer ] map ; 13 | 14 | : (resize-image) ( image scale cr -- ) 15 | { 16 | [ swap first2 cairo_scale ] 17 | [ swap image>cairo-surface 0 0 cairo_set_source_surface ] 18 | [ 19 | cairo_get_source CAIRO_FILTER_BEST 20 | cairo_pattern_set_filter 21 | ] 22 | [ cairo_paint ] 23 | } cleave ; 24 | 25 | : resize-image ( image scale -- image' ) 26 | 2dup [ dim>> ] dip scale-size 27 | [ (resize-image) ] make-bitmap-image ; 28 | -------------------------------------------------------------------------------- /examples/lpath/agraph: -------------------------------------------------------------------------------- 1 | 15 2 | 0 1 1127 3 | 0 7 891 4 | 0 6 802 5 | 0 9 796 6 | 0 12 68 7 | 0 13 206 8 | 0 11 771 9 | 0 14 1123 10 | 1 2 808 11 | 1 5 477 12 | 1 9 611 13 | 1 3 639 14 | 1 8 743 15 | 1 13 1000 16 | 2 3 409 17 | 2 13 606 18 | 2 6 242 19 | 2 11 451 20 | 2 10 439 21 | 2 1 808 22 | 2 5 642 23 | 2 0 569 24 | 2 4 375 25 | 2 9 263 26 | 2 14 771 27 | 2 8 181 28 | 2 7 648 29 | 2 12 629 30 | 3 4 241 31 | 3 10 101 32 | 3 8 234 33 | 3 5 270 34 | 3 12 555 35 | 3 2 409 36 | 3 9 472 37 | 3 7 403 38 | 3 1 639 39 | 3 0 488 40 | 3 13 374 41 | 4 5 318 42 | 4 13 611 43 | 4 7 273 44 | 4 14 439 45 | 4 6 361 46 | 4 0 696 47 | 4 2 375 48 | 4 3 241 49 | 4 10 170 50 | 4 11 83 51 | 4 8 284 52 | 4 1 459 53 | 4 9 292 54 | 5 6 679 55 | 5 8 487 56 | 5 11 302 57 | 6 7 595 58 | 6 5 679 59 | 6 4 361 60 | 6 12 865 61 | 7 8 544 62 | 7 3 403 63 | 7 2 648 64 | 7 5 239 65 | 8 9 339 66 | 8 6 359 67 | 8 0 460 68 | 8 7 544 69 | 8 4 284 70 | 8 11 368 71 | 8 5 487 72 | 8 3 234 73 | 9 10 442 74 | 10 11 210 75 | 10 1 538 76 | 10 3 101 77 | 10 12 657 78 | 10 5 204 79 | 10 0 590 80 | 10 8 284 81 | 10 14 538 82 | 10 6 503 83 | 10 2 439 84 | 11 12 840 85 | 11 8 368 86 | 11 3 300 87 | 11 6 403 88 | 11 7 200 89 | 11 9 328 90 | 11 2 451 91 | 11 5 302 92 | 11 4 83 93 | 11 14 357 94 | 11 1 375 95 | 11 10 210 96 | 11 0 771 97 | 11 13 674 98 | 12 13 247 99 | 13 14 1007 100 | 13 8 449 101 | 13 11 674 102 | 13 0 206 103 | 13 10 470 104 | 13 5 554 105 | 13 4 611 106 | 13 2 606 107 | 13 3 374 108 | 13 12 247 109 | 13 7 755 110 | 13 6 808 111 | 13 1 1000 112 | 13 9 783 113 | 14 0 1123 114 | 14 7 266 115 | 14 3 639 116 | 14 5 505 117 | 14 12 1191 118 | 14 1 72 119 | 14 10 538 120 | 14 8 721 121 | 14 4 439 122 | 14 13 1007 123 | 14 6 632 124 | -------------------------------------------------------------------------------- /examples/lpath/lpath.factor: -------------------------------------------------------------------------------- 1 | USING: arrays grouping.extras io.encodings.utf8 io.files kernel kernel.private 2 | locals math math.integers.private math.parser math.private sequences 3 | sequences.private slots.private splitting tools.time ; 4 | IN: lpath 5 | 6 | : parse-graph ( str -- data ) 7 | utf8 file-lines rest [ " " split harvest [ string>number ] map ] map ; 8 | 9 | : reshape-graph ( data -- seq ) 10 | [ first ] group-by [ second [ rest ] { } map-as ] { } map-as ; 11 | 12 | : read-graph ( str -- G ) 13 | parse-graph reshape-graph ; 14 | 15 | : initial-visited ( G -- array ) 16 | length 0 ; 17 | 18 | ! Helps Factor generate unsafe assembly. 19 | : fast-add ( fix1 fix2 -- fix3 ) 20 | { fixnum fixnum } declare fixnum+fast ; inline 21 | 22 | : fast-array-nth ( arr fix -- el ) 23 | { array fixnum } declare swap nth-unsafe ; inline 24 | 25 | : fast-first2 ( arr -- el1 el2 ) 26 | { array } declare first2-unsafe ; inline 27 | 28 | DEFER: (longest-path) 29 | 30 | :: ((longest-path)) ( G visited neighbours len i running-max -- running-max' ) 31 | len i eq? [ running-max ] [ 32 | neighbours i fast-array-nth 33 | fast-first2 dupd visited rot fast-array-nth 1 eq? 34 | [ 2drop running-max ] [ 35 | swap G visited rot (longest-path) fast-add running-max fixnum-max 36 | ] if 37 | [ G visited neighbours len i 1 fast-add ] dip ((longest-path)) 38 | ] if ; inline recursive 39 | 40 | : (longest-path) ( G visited id -- value ) 41 | { array array fixnum } declare 42 | 2dup swap 1 -rot set-array-nth 43 | 3dup pick array-nth dup array-length 0 0 ((longest-path)) 44 | [ swap 0 -rot set-array-nth drop ] dip ; 45 | 46 | : longest-path ( G visited -- path-length ) 47 | 0 (longest-path) ; 48 | 49 | : run-test ( path -- longest nanos ) 50 | read-graph dup initial-visited [ longest-path ] benchmark ; 51 | -------------------------------------------------------------------------------- /examples/math/matrices/matrices.factor: -------------------------------------------------------------------------------- 1 | USING: 2 | arrays.shaped 3 | kernel literals locals 4 | math.affine-transforms math.vectors math.matrices random sequences ; 5 | IN: examples.math.matrices 6 | 7 | : nrand ( shape -- out ) 8 | [ product [ 0 1 normal-random-float ] replicate ] 9 | [ ] bi shaped-array>array ; 10 | 11 | : ( w h -- mat ) 12 | f [ drop 0 1 normal-random-float ] matrix-map ; 13 | 14 | : H ( -- m ) 15 | { 16 | { 1 2 3 4 5 -20 7 8 9 10 } 17 | { 10 9 8 7 6 5 4 3 2 9 } 18 | } ; 19 | 20 | : V ( -- m ) 21 | { 22 | { 1 2 3 4 5 6 7 8 9 10 } 23 | { 10 9 8 7 6 5 4 3 2 1 } 24 | { 1 2 3 4 5 6 7 8 9 10 } 25 | { 10 9 8 7 6 5 4 3 2 1 } 26 | { 1 2 3 4 5 6 7 8 9 10 } 27 | { 10 9 8 7 6 5 4 3 2 1 } 28 | { 1 2 3 4 5 6 7 8 9 10 } 29 | { 10 9 8 7 6 5 4 3 2 1 } 30 | { 1 2 3 4 5 6 7 8 9 10 } 31 | { 10 9 8 7 6 5 4 3 2 1 } 32 | } ; 33 | 34 | 35 | : beta ( -- v ) 36 | { 37 | { 20 30 40 50 60 70 80 90 100 3 } 38 | { 3 9 3 9 3 3 9 3 9 3 } 39 | } ; 40 | 41 | : r ( -- m ) 42 | { { 5 -5 } { 2 3 } } ; 43 | 44 | :: calc ( H V beta r -- S ) 45 | H beta m. r m- ; 46 | -------------------------------------------------------------------------------- /examples/math/ops/ops.factor: -------------------------------------------------------------------------------- 1 | USING: fry kernel math prettyprint sequences sequences.generalizations ; 2 | IN: examples.math.ops 3 | 4 | ! If you know about array-based languages, then you know that most of 5 | ! their words are polymorphic over their data types 6 | ! dimensionality. So, the same word can be used for 0 dimensional 7 | ! (scalar), 1-dimensional (sequences), 2-dimensional, 8 | ! ... N-dimensional data structures. 9 | 10 | ! You can define words in Factor to work in the same way, but usually 11 | ! that's not how it is done. Instead, it is interesting to realize 12 | ! that map is a word that takes a unary word operating on scalar and 13 | ! making it work with sequences. 14 | 15 | ! Consider 16 | 17 | IN: scratchpad -9 abs . 18 | 19 | ! And the sequence variant 20 | 21 | IN: scratchpad { -9 3 0 -1 } [ abs ] map . 22 | 23 | ! The pattern is clear, let's make a word for it 24 | 25 | : raise-un ( quot: ( a -- b ) -- quot': ( a b -- c ) ) 26 | [ map ] curry ; 27 | 28 | ! Now you can write 29 | 30 | IN: scratchpad { -9 3 0 -1 } [ abs ] raise-un call( x -- x ) . 31 | 32 | ! Cool! 33 | 34 | ! We can do the same with binary words: 35 | 36 | : raise-bin ( quot: ( a b -- c ) -- quot': ( a b -- c ) ) 37 | [ 2map ] curry ; 38 | 39 | IN: scratchpad { 3 4 } { 5 6 } [ * ] raise-bin call( a b -- c ) . 40 | 41 | ! If we call denote * as *[0:0] because it works on scalars, then the 42 | ! above would be denoted as *[1:1] and *[2:2] would be: 43 | 44 | IN: scratchpad { { 3 4 } } { { 5 6 } } [ * ] raise-bin raise-bin 45 | call( a b -- c ) . 46 | 47 | ! 3map does the same thing for tertiary words. How about words with 48 | ! arbitrary arity? nmap can be used: 49 | 50 | : raise-arity ( n quot: ( * -- x ) -- quot': ( * -- x ) ) 51 | [ nmap ] swapd 2curry ; 52 | 53 | IN: scratchpad { 1 32 } { 3 3 } { 3 3 } 3 [ + * ] raise-arity 54 | call( x y z -- w ) . 55 | 56 | ! Neat! So we took a quotation operating on three numbers and made it 57 | ! operate on three sequences instead. It could have been called 58 | ! +*[1:1:1]. 59 | 60 | 61 | ! Now here comes the interesting part. How do we construct *[1:0]? 62 | 63 | : raise-bin-left ( b quot: ( a b -- c ) -- quot': ( a -- c ) ) 64 | curry [ map ] curry ; 65 | 66 | IN: scratchpad { 3 4 } 3 [ * ] raise-bin-left call( x -- x ) . 67 | 68 | ! It's not as symmetrical, and the result would be denoted: *[1] 69 | 70 | ! 2:0 works too: 71 | 72 | IN: scratchpad { { 3 4 } { 8 } } 3 [ * ] raise-bin-left raise-un 73 | call( x -- y ) . 74 | 75 | ! 3:0 76 | 77 | IN: scratchpad { { { 3 4 } { 8 } } } 3 [ * ] raise-bin-left 78 | raise-un raise-un call( x -- x ) . 79 | 80 | ! 2:1, 3:1, 0:1, 0:2 and other similar dimension matchings has no good 81 | ! mathematical interpretation. 82 | -------------------------------------------------------------------------------- /examples/multiline/multiline.factor: -------------------------------------------------------------------------------- 1 | ! How to use the multiline vocab 2 | USING: multiline ; 3 | IN: examples.multiline 4 | 5 | STRING: text1 6 | .....w.b.w.. 7 | ww..b...b... 8 | .w.....b.... 9 | ...wbww..b.b 10 | ....b....... 11 | w.w......... 12 | ..w......b.b 13 | .....bb..... 14 | .....b.....w 15 | w.ww..b..... 16 | ...w......w. 17 | b..w.....b.. 18 | ; 19 | 20 | CONSTANT: text2 "hello" 21 | -------------------------------------------------------------------------------- /examples/python/mutagen/mutagen-test.py: -------------------------------------------------------------------------------- 1 | from mutagen.easyid3 import EasyID3 2 | # import mutagen.id3 3 | # print dir(mutagen) 4 | 5 | meta = EasyID3("/mnt/bigdisk/newmus/bob.dylan/07 - You Ain't Goin' Nowhere.mp3") 6 | meta["title"] = "Hello Test" 7 | meta.save() 8 | -------------------------------------------------------------------------------- /examples/python/mutagen/mutagen.factor: -------------------------------------------------------------------------------- 1 | USING: kernel python python.syntax sequences ; 2 | IN: examples.python.mutagen 3 | 4 | PY-QUALIFIED-FROM: mutagen.easyid3 => EasyID3 ( name -- obj ) ; 5 | PY-METHODS: mutagen:easyid3:EasyID3 => 6 | __setitem__ ( self key value -- ) 7 | save ( self -- ) ; 8 | 9 | : ( str -- easyid3 ) 10 | >py mutagen.easyid3:EasyID3 ; 11 | 12 | : setitem ( obj key val -- ) 13 | [ >py ] bi@ __setitem__ ; 14 | 15 | : update-tags ( easyid3 assoc -- ) 16 | dupd [ first2 setitem ] with each save ; 17 | -------------------------------------------------------------------------------- /examples/sequences/sequences.factor: -------------------------------------------------------------------------------- 1 | USING: accessors alien.strings classes.struct combinators 2 | continuations io.backend io.directories.unix io.files.info kernel math 3 | sequences unix.ffi ; 4 | FROM: io.directories.unix.linux => next-dirent ; 5 | IN: examples.sequences 6 | 7 | DEFER: directory-size 8 | 9 | : entry-size-file ( name -- size ) 10 | file-info size>> ; 11 | 12 | : entry-size-dir ( name -- size ) 13 | dup { "." ".." } member? [ drop 0 ] [ 14 | normalize-path directory-size 15 | ] if ; 16 | 17 | : entry-size ( dirent* -- size ) 18 | [ d_name>> alien>native-string ] [ d_type>> ] bi { 19 | { DT_REG [ entry-size-file ] } 20 | { DT_DIR [ entry-size-dir ] } 21 | [ 2drop 0 ] 22 | } case ; 23 | 24 | : dirent-size ( unix-dir dirent -- size/f ) 25 | next-dirent [ entry-size ] [ drop f ] if ; 26 | 27 | : (directory-size) ( unix-dir dirent -- total ) 28 | 2dup dirent-size [ -rot (directory-size) + ] [ 2drop 0 ] if* ; 29 | 30 | : directory-size ( path -- total ) 31 | [ 32 | [ dirent (directory-size) ] with-unix-directory 33 | ] [ 2drop 0 ] recover ; 34 | -------------------------------------------------------------------------------- /examples/sockets/rawhttp/rawhttp.factor: -------------------------------------------------------------------------------- 1 | USING: alien.strings byte-arrays combinators io.sockets 2 | io.sockets.private kernel sequences system vocabs.parser words ; 3 | IN: examples.sockets.rawhttp 4 | 5 | << os windows? [ "windows.winsock" ] [ "unix.ffi" ] if use-vocab >> 6 | 7 | : do-send ( s buf len flags -- n ) 8 | os { 9 | { windows [ 10 | "send" "windows.winsock" lookup-word 11 | execute( a b c d -- n ) 12 | ] } 13 | [ 14 | drop [ native-string>alien ] 2dip f 0 15 | "sendto" "unix.ffi" lookup-word 16 | execute( a b c d e f -- n ) 17 | ] 18 | } case ; 19 | 20 | : do-http ( host -- arr ) 21 | ! Step 1. Resolve the host. 22 | 80 resolve-host first 23 | ! Step 2. Create a socket. 24 | AF_INET SOCK_STREAM IPPROTO_TCP socket 25 | ! Step 3. Connect to the host. 26 | [ 27 | swap make-sockaddr/size connect 0 assert= 28 | ] 29 | ! Step 4. Send a GET request 30 | [ 31 | "GET / HTTP/1.1\r\n\r\n" dup length [ 0 do-send ] keep 32 | assert= 33 | ] 34 | ! Step 5. Recv data into a byte buffer. 35 | [ 36 | 100 dup swap [ 0 recv ] 2keep swapd 37 | assert= 38 | ] tri ; 39 | -------------------------------------------------------------------------------- /examples/sockets/resolving/resolving.factor: -------------------------------------------------------------------------------- 1 | USING: accessors alien.c-types alien.data alien.destructors classes.struct 2 | destructors io.sockets kernel windows.winsock ; 3 | IN: examples.sockets.resolving 4 | 5 | DESTRUCTOR: freeaddrinfo 6 | 7 | : addrinfo-hints ( -- hints ) 8 | addrinfo 9 | IPPROTO_TCP >>protocol 10 | AF_UNSPEC >>family 11 | SOCK_STREAM >>socktype ; 12 | 13 | : resolve-v1 ( host -- stuff ) 14 | ! host plus three more arguments to getaddrinfo. Note that the 15 | ! last argument is an output argument to be filled in by the 16 | ! function. 17 | f addrinfo-hints { void* } [ 18 | ! Run getaddrinfo and attach a destructor to the allocated 19 | ! addrinfo. 20 | [ getaddrinfo 0 assert= ] with-out-parameters &freeaddrinfo 21 | ! "Cast" it to an addrinfo and follow the path. Kind of like 22 | ! ptr->ai_addr->sin_addr in C. 23 | addrinfo memory>struct addr>> sockaddr-in memory>struct addr>> 24 | inet_ntoa 25 | ] with-destructors ; 26 | -------------------------------------------------------------------------------- /examples/syntax/tuples/tuples.factor: -------------------------------------------------------------------------------- 1 | ! How to use the CONSTRUCTOR: syntax. 2 | USING: constructors io.sockets math strings unix.users ; 3 | IN: examples.syntax.tuples 4 | 5 | TUPLE: mysql-db 6 | { host string initial: "127.0.0.1" } 7 | { user string initial: "root" } 8 | { password string } 9 | { database string initial: "test" } 10 | { port integer initial: 3306 } 11 | { unixsocket string } 12 | { clientflag integer } 13 | resulthandle ; 14 | 15 | CONSTRUCTOR: mysql-db ( host user password -- mysql-db ) ; 16 | 17 | : your-unix-mysql-db ( -- db ) 18 | host-name real-user-name "hunter2" ; 19 | -------------------------------------------------------------------------------- /examples/threads/greeters/greeters.factor: -------------------------------------------------------------------------------- 1 | ! How to spawn threads 2 | USING: accessors calendar formatting io kernel math sequences threads ; 3 | IN: examples.threads.greeters 4 | 5 | : greeting ( n -- ) 6 | self id>> "greeting %d from %d...\n" printf flush ; 7 | : delay ( -- ) 8 | 1 seconds sleep ; 9 | : greeter ( -- ) 10 | 10 iota [ greeting delay ] each ; 11 | 12 | : main ( -- ) 13 | 10 [ [ greeter ] "printer" spawn drop ] times 14 | 20 seconds sleep ; 15 | 16 | MAIN: main 17 | -------------------------------------------------------------------------------- /examples/threads/threads.factor: -------------------------------------------------------------------------------- 1 | USING: calendar fry kernel math.order threads ; 2 | IN: examples.threads 3 | 4 | : make-timeout-check ( duration -- quot ) 5 | now time+ '[ now _ <=> +lt+ = ] ; inline 6 | 7 | : repeat-for ( duration quot -- ) 8 | [ make-timeout-check ] dip while ; inline 9 | -------------------------------------------------------------------------------- /examples/transforms/transforms.factor: -------------------------------------------------------------------------------- 1 | USING: accessors arrays combinators effects kernel make math sequences 2 | sequences.rotated shuffle stack-checker ; 3 | IN: examples.transforms 4 | 5 | : make-shuffle-effect ( n dir -- effect ) 6 | swap 1 + iota swap dupd [ >array ] bi@ ; 7 | 8 | : emit-dip ( quot -- ) 9 | dup infer 10 | [ nip in>> length -1 make-shuffle-effect , \ shuffle-effect , ] 11 | [ swap , , \ call-effect , ] 12 | [ nip out>> length 1 make-shuffle-effect , \ shuffle-effect , ] 2tri ; 13 | 14 | : rewrite-dip ( quot -- quot' ) 15 | first2 drop [ emit-dip ] [ ] make ; 16 | -------------------------------------------------------------------------------- /examples/trees/trees.factor: -------------------------------------------------------------------------------- 1 | ! You can use these words on almost anything tree-like. As long as you 2 | ! provide node-children and set-node-children. 3 | USING: accessors byte-arrays fry generic io kernel math namespaces 4 | prettyprint sequences strings words ; 5 | IN: examples.trees 6 | 7 | GENERIC: node-children ( node -- nodes ) 8 | GENERIC# set-node-children 1 ( node nodes -- node' ) 9 | 10 | SYMBOL: visited-nodes 11 | 12 | : (tree-walker) ( quot: ( .. node depth -- ... ) depth node -- ) 13 | dup visited-nodes get member? [ 3drop ] [ 14 | dup visited-nodes [ swap suffix ] change 15 | [ rot swapd call( node depth -- ) ] 16 | [ [ 1 + ] dip node-children [ (tree-walker) ] with with each ] 3bi 17 | ] if ; 18 | 19 | : tree-walker ( node quot: ( .. node depth -- ... ) -- ) 20 | { } visited-nodes [ 0 rot (tree-walker) ] with-variable ; 21 | 22 | : node-print ( node depth -- ) 23 | 2 * CHAR: \s write short. ; 24 | 25 | : tree-printer ( node -- ) 26 | [ node-print ] tree-walker ; 27 | 28 | : tree-filter ( node quot: ( ... elt -- ... ? ) -- node' ) 29 | over node-children swap [ filter ] keep 30 | '[ _ tree-filter ] map set-node-children ; inline recursive 31 | 32 | M: object set-node-children ( node nodes -- node' ) 33 | drop ; 34 | M: sequence set-node-children ( node nodes -- node' ) 35 | nip ; 36 | 37 | 38 | M: object node-children drop f ; 39 | M: sequence node-children ; 40 | 41 | ! Strings and byte array children are uninteresting. 42 | M: string node-children drop f ; 43 | M: byte-array node-children drop f ; 44 | M: word node-children def>> ; 45 | 46 | ! generics have to many children 47 | M: generic node-children drop f ; 48 | 49 | : try-this ( -- ) 50 | \ filter-as tree-printer ; 51 | -------------------------------------------------------------------------------- /examples/ui/editor/editor.factor: -------------------------------------------------------------------------------- 1 | USING: accessors fry io.encodings.utf8 io.files kernel ui ui.gadgets.editors 2 | ui.gadgets.scrollers ; 3 | IN: examples.ui.editor 4 | 5 | : show-file ( file -- ) 6 | { 300 400 } >>pref-dim 7 | over utf8 file-contents over set-editor-string 8 | swap '[ _ _ open-window ] with-ui ; 9 | -------------------------------------------------------------------------------- /examples/ui/gtk/hello/hello.factor: -------------------------------------------------------------------------------- 1 | ! Demonstrates how to write a GTK application in Factor. 2 | ! 3 | ! See also the samples in extra/gtk-samples/* in the Factor 4 | ! distribution. 5 | USING: alien.c-types alien.data alien.strings 6 | gobject-introspection.standard-types gtk.ffi io.encodings.utf8 kernel 7 | ui.backend.gtk ; 8 | IN: examples.ui.gtk.hello 9 | 10 | : start-gtk ( -- ) 11 | f f gtk_init ; 12 | 13 | : connect-signals ( win -- ) 14 | "destroy" [ 2drop gtk_main_quit ] GtkObject:destroy connect-signal ; 15 | 16 | : setup-gtk ( -- ) 17 | GTK_WINDOW_TOPLEVEL gtk_window_new 18 | [ 19 | "Hello, World!" utf8 string>alien gtk_button_new_with_label 20 | gtk_container_add 21 | ] 22 | [ connect-signals ] 23 | [ gtk_widget_show_all ] tri ; 24 | 25 | : hello-gtk ( -- ) 26 | start-gtk setup-gtk gtk_main ; 27 | 28 | MAIN: hello-gtk 29 | -------------------------------------------------------------------------------- /examples/ui/gtk/input/input.factor: -------------------------------------------------------------------------------- 1 | ! Demonstrates simple input event handling in GTK. 2 | ! 3 | ! See also the samples in extra/gtk-samples/* in the Factor 4 | ! distribution. 5 | USING: alien.strings arrays formatting gtk.ffi io.encodings.utf8 6 | kernel locals sequences ui.backend.gtk ; 7 | IN: examples.ui.gtk.input 8 | 9 | : string>gtk ( str -- alien ) 10 | utf8 string>alien ; 11 | 12 | : gtk>string ( alien -- str ) 13 | utf8 alien>string ; 14 | 15 | : start-gtk ( -- ) 16 | f f gtk_init ; 17 | 18 | : connect-signals ( win -- ) 19 | "destroy" [ 2drop gtk_main_quit ] GtkObject:destroy connect-signal ; 20 | 21 | : show-info-dialog ( text -- ) 22 | f GTK_DIALOG_MODAL GTK_MESSAGE_INFO GTK_BUTTONS_OK f f 23 | gtk_message_dialog_new 24 | [ swap string>gtk gtk_message_dialog_set_markup ] 25 | [ gtk_dialog_run drop ] 26 | [ gtk_widget_destroy ] tri ; 27 | 28 | : button-press ( button user_data -- ) 29 | nip gtk_entry_get_text gtk>string 30 | "Hello, %s! How are you doing?" sprintf show-info-dialog ; 31 | 32 | :