--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: bit-arrays formatting fry kernel math math.ranges
+sequences ;
+IN: rosetta-code.100-doors
+
+! http://rosettacode.org/wiki/100_doors
+
+! Problem: You have 100 doors in a row that are all initially
+! closed. You make 100 passes by the doors. The first time
+! through, you visit every door and toggle the door (if the door
+! is closed, you open it; if it is open, you close it). The second
+! time you only visit every 2nd door (door #2, #4, #6, ...). The
+! third time, every 3rd door (door #3, #6, #9, ...), etc, until
+! you only visit the 100th door.
+
+! Question: What state are the doors in after the last pass?
+! Which are open, which are closed? [1]
+
+! Alternate: As noted in this page's discussion page, the only
+! doors that remain open are whose numbers are perfect squares of
+! integers. Opening only those doors is an optimization that may
+! also be expressed.
+
+CONSTANT: number-of-doors 100
+
+: multiples ( n -- range )
+ 0 number-of-doors rot <range> ;
+
+: toggle-multiples ( n doors -- )
+ [ multiples ] dip '[ _ [ not ] change-nth ] each ;
+
+: toggle-all-multiples ( doors -- )
+ [ number-of-doors [1,b] ] dip '[ _ toggle-multiples ] each ;
+
+: print-doors ( doors -- )
+ [
+ swap "open" "closed" ? "Door %d is %s\n" printf
+ ] each-index ;
+
+: doors-main ( -- )
+ number-of-doors 1 + <bit-array>
+ [ toggle-all-multiples ] [ print-doors ] bi ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators locals kernel math ;
+IN: rosetta-code.ackermann
+
+! http://rosettacode.org/wiki/Ackermann_function
+
+! The Ackermann function is a classic recursive example in
+! computer science. It is a function that grows very quickly (in
+! its value and in the size of its call tree). It is defined as
+! follows:
+
+! A(m,n) = {
+! n + 1 if m = 0
+! A(m-1, 1) if m > 0 and n = 0
+! A(m-1, A(m, n-1)) if m > 0 and n > 0
+! }
+
+! Its arguments are never negative and it always terminates.
+! Write a function which returns the value of A(m,n). Arbitrary
+! precision is preferred (since the function grows so quickly),
+! but not required.
+
+:: ackermann ( m n -- u )
+ {
+ { [ m 0 = ] [ n 1 + ] }
+ { [ n 0 = ] [ m 1 - 1 ackermann ] }
+ [ m 1 - m n 1 - ackermann ackermann ]
+ } cond ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar combinators kernel locals math
+math.constants math.functions prettyprint system threads timers ;
+IN: rosetta-code.active-object
+
+! http://rosettacode.org/wiki/Active_object
+
+! In object-oriented programming an object is active when its
+! state depends on clock. Usually an active object encapsulates a
+! task that updates the object's state. To the outer world the
+! object looks like a normal object with methods that can be
+! called from outside. Implementation of such methods must have a
+! certain synchronization mechanism with the encapsulated task in
+! order to prevent object's state corruption.
+
+! A typical instance of an active object is an animation widget.
+! The widget state changes with the time, while as an object it
+! has all properties of a normal widget.
+
+! The task
+
+! Implement an active integrator object. The object has an input
+! and output. The input can be set using the method Input. The
+! input is a function of time. The output can be queried using the
+! method Output. The object integrates its input over the time and
+! the result becomes the object's output. So if the input is K(t)
+! and the output is S, the object state S is changed to S + (K(t1)
+! + K(t0)) * (t1 - t0) / 2, i.e. it integrates K using the trapeze
+! method. Initially K is constant 0 and S is 0.
+
+! In order to test the object:
+! * set its input to sin (2π f t), where the frequency f=0.5Hz.
+! The phase is irrelevant.
+! * wait 2s
+! * set the input to constant 0
+! * wait 0.5s
+
+! Verify that now the object's output is approximately 0 (the
+! sine has the period of 2s). The accuracy of the result will
+! depend on the OS scheduler time slicing and the accuracy of the
+! clock.
+
+TUPLE: active-object timer function state previous-time ;
+
+: apply-stack-effect ( quot -- quot' )
+ [ call( x -- x ) ] curry ; inline
+
+: nano-to-seconds ( -- seconds ) nano-count 9 10^ / ;
+
+: object-times ( active-object -- t1 t2 )
+ [ previous-time>> ]
+ [ nano-to-seconds [ >>previous-time drop ] keep ] bi ;
+
+:: adding-function ( t1 t2 active-object -- function )
+ t2 t1 active-object function>> apply-stack-effect bi@ +
+ t2 t1 - * 2 / [ + ] curry ;
+
+: integrate ( active-object -- )
+ [ object-times ]
+ [ adding-function ]
+ [ swap apply-stack-effect change-state drop ] tri ;
+
+: <active-object> ( -- object )
+ active-object new
+ 0 >>state
+ nano-to-seconds >>previous-time
+ [ drop 0 ] >>function
+ dup [ integrate ] curry 1 nanoseconds every >>timer ;
+
+: destroy ( active-object -- ) timer>> stop-timer ;
+
+: input ( object quot -- object ) >>function ;
+
+: output ( object -- val ) state>> ;
+
+: active-test ( -- )
+ <active-object>
+ [ 2 pi 0.5 * * * sin ] input
+ 2 seconds sleep
+ [ drop 0 ] input
+ 0.5 seconds sleep
+ [ output . ] [ destroy ] bi ;
+
+MAIN: active-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry io kernel math math.functions math.order sequences
+splitting strings ;
+IN: rosetta.align-columns
+
+! http://rosettacode.org/wiki/Align_columns
+
+! Given a text file of many lines, where fields within a line
+! are delineated by a single 'dollar' character, write a program
+! that aligns each column of fields by ensuring that words in each
+! column are separated by at least one space. Further, allow for
+! each word in a column to be either left justified, right
+! justified, or center justified within its column.
+
+! Use the following text to test your programs:
+
+! Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+! are$delineated$by$a$single$'dollar'$character,$write$a$program
+! that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+! column$are$separated$by$at$least$one$space.
+! Further,$allow$for$each$word$in$a$column$to$be$either$left$
+! justified,$right$justified,$or$center$justified$within$its$column.
+
+! Note that:
+
+! * The example input texts lines may, or may not, have trailing
+! dollar characters.
+! * All columns should share the same alignment.
+! * Consecutive space characters produced adjacent to the end of
+! lines are insignificant for the purposes of the task.
+! * Output text will be viewed in a mono-spaced font on a plain
+! text editor or basic terminal.
+! * The minimum space between columns should be computed from
+! the text and not hard-coded.
+! * It is not a requirement to add separating characters between
+! or around columns.
+
+CONSTANT: example-text "Given$a$text$file$of$many$lines,$where$fields$within$a$line$
+are$delineated$by$a$single$'dollar'$character,$write$a$program
+that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$
+column$are$separated$by$at$least$one$space.
+Further,$allow$for$each$word$in$a$column$to$be$either$left$
+justified,$right$justified,$or$center$justified$within$its$column."
+
+: split-and-pad ( text -- lines )
+ "\n" split [ "$" split harvest ] map
+ dup [ length ] [ max ] map-reduce
+ '[ _ "" pad-tail ] map ;
+
+: column-widths ( columns -- widths )
+ [ [ length ] [ max ] map-reduce ] map ;
+
+SINGLETONS: +left+ +middle+ +right+ ;
+
+GENERIC: align-string ( str n alignment -- str' )
+
+M: +left+ align-string drop CHAR: space pad-tail ;
+M: +right+ align-string drop CHAR: space pad-head ;
+
+M: +middle+ align-string
+ drop
+ over length - 2 /
+ [ floor CHAR: space <string> ]
+ [ ceiling CHAR: space <string> ] bi surround ;
+
+: align-columns ( columns alignment -- columns' )
+ [ dup column-widths ] dip '[
+ [ _ align-string ] curry map
+ ] 2map ;
+
+: print-aligned ( text alignment -- )
+ [ split-and-pad flip ] dip align-columns flip
+ [ [ write " " write ] each nl ] each ;
+
+! USAGE: example-text +left+ print-aligned
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: backtrack continuations kernel prettyprint sequences ;
+IN: rosetta-code.amb
+
+! http://rosettacode.org/wiki/Amb
+
+! Define and give an example of the Amb operator.
+
+! The Amb operator takes some number of expressions (or values
+! if that's simpler in the language) and nondeterministically
+! yields the one or fails if given no parameter, amb returns the
+! value that doesn't lead to failure.
+
+! The example is using amb to choose four words from the following strings:
+
+! set 1: "the" "that" "a"
+! set 2: "frog" "elephant" "thing"
+! set 3: "walked" "treaded" "grows"
+! set 4: "slowly" "quickly"
+
+! It is a failure if the last character of word 1 is not equal
+! to the first character of word 2, and similarly with word 2 and
+! word 3, as well as word 3 and word 4. (the only successful
+! sentence is "that thing grows slowly").
+
+CONSTANT: words {
+ { "the" "that" "a" }
+ { "frog" "elephant" "thing" }
+ { "walked" "treaded" "grows" }
+ { "slowly" "quickly" }
+}
+
+: letters-match? ( str1 str2 -- ? ) [ last ] [ first ] bi* = ;
+
+: sentence-match? ( seq -- ? ) dup rest [ letters-match? ] 2all? ;
+
+: select ( seq -- seq' ) [ amb-lazy ] map ;
+
+: search ( -- )
+ words select dup sentence-match? [ " " join ] [ fail ] if . ;
+
+MAIN: search
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs fry http.client io.encodings.utf8 io.files
+io.files.temp kernel math math.combinatorics sequences sorting
+strings urls ;
+
+IN: rosettacode.anagrams-deranged
+
+! http://rosettacode.org/wiki/Anagrams/Deranged_anagrams
+
+! Two or more words are said to be anagrams if they have the
+! same characters, but in a different order. By analogy with
+! derangements we define a deranged anagram as two words with the
+! same characters, but in which the same character does not appear
+! in the same position in both words.
+
+! The task is to use the word list at
+! http://www.puzzlers.org/pub/wordlists/unixdict.txt to find and
+! show the longest deranged anagram.
+
+: derangement? ( str1 str2 -- ? ) [ = not ] 2all? ;
+
+: derangements ( seq -- seq )
+ 2 [ first2 derangement? ] filter-combinations ;
+
+: parse-dict-file ( path -- hash )
+ utf8 file-lines
+ H{ } clone [
+ '[
+ [ natural-sort >string ] keep
+ _ [ swap suffix ] with change-at
+ ] each
+ ] keep ;
+
+: anagrams ( hash -- seq )
+ [ nip length 1 > ] assoc-filter values ;
+
+: deranged-anagrams ( path -- seq )
+ parse-dict-file anagrams [ derangements ] map concat ;
+
+: (longest-deranged-anagrams) ( path -- anagrams )
+ deranged-anagrams [ first length ] sort-with last ;
+
+: default-word-list ( -- path )
+ "unixdict.txt" temp-file dup exists? [
+ URL" http://puzzlers.org/pub/wordlists/unixdict.txt"
+ over download-to
+ ] unless ;
+
+: longest-deranged-anagrams ( -- anagrams )
+ default-word-list (longest-deranged-anagrams) ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar colors.constants kernel
+locals math math.constants math.functions math.rectangles
+math.vectors opengl sequences system timers ui ui.gadgets ui.render ;
+IN: rosetta-code.animate-pendulum
+
+! http://rosettacode.org/wiki/Animate_a_pendulum
+
+! One good way of making an animation is by simulating a
+! physical system and illustrating the variables in that system
+! using a dynamically changing graphical display. The classic such
+! physical system is a simple gravity pendulum.
+
+! For this task, create a simple physical model of a pendulum
+! and animate it.
+
+CONSTANT: g 9.81
+CONSTANT: l 20
+CONSTANT: theta0 0.5
+
+: current-time ( -- time ) nano-count -9 10^ * ;
+
+: T0 ( -- T0 ) 2 pi l g / sqrt * * ;
+: omega0 ( -- omega0 ) 2 pi * T0 / ;
+: theta ( -- theta ) current-time omega0 * cos theta0 * ;
+
+: relative-xy ( theta l -- xy )
+ [ [ sin ] [ cos ] bi ]
+ [ [ * ] curry ] bi* bi@ 2array ;
+: theta-to-xy ( origin theta l -- xy ) relative-xy v+ ;
+
+TUPLE: pendulum-gadget < gadget alarm ;
+
+: O ( gadget -- origin ) rect-bounds [ drop ] [ first 2 / ] bi* 0 2array ;
+: window-l ( gadget -- l ) rect-bounds [ drop ] [ second ] bi* ;
+: gadget-xy ( gadget -- xy ) [ O ] [ drop theta ] [ window-l ] tri theta-to-xy ;
+
+M: pendulum-gadget draw-gadget*
+ COLOR: black gl-color
+ [ O ] [ gadget-xy ] bi gl-line ;
+
+M: pendulum-gadget graft* ( gadget -- )
+ [ call-next-method ]
+ [
+ dup [ relayout-1 ] curry
+ 20 milliseconds every >>alarm drop
+ ] bi ;
+
+M: pendulum-gadget ungraft*
+ [ alarm>> stop-timer ] [ call-next-method ] bi ;
+
+: <pendulum-gadget> ( -- gadget )
+ pendulum-gadget new
+ { 500 500 } >>pref-dim ;
+
+: pendulum-main ( -- )
+ [ <pendulum-gadget> "pendulum" open-window ] with-ui ;
+
+MAIN: pendulum-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors timers calendar fonts kernel models sequences ui
+ui.gadgets ui.gadgets.labels ui.gestures ;
+FROM: models => change-model ;
+IN: rosetta-code.animation
+
+! http://rosettacode.org/wiki/Animation
+
+! Animation is the foundation of a great many parts of graphical
+! user interfaces, including both the fancy effects when things
+! change used in window managers, and of course games. The core of
+! any animation system is a scheme for periodically changing the
+! display while still remaining responsive to the user. This task
+! demonstrates this.
+
+! Create a window containing the string "Hello World! " (the
+! trailing space is significant). Make the text appear to be
+! rotating right by periodically removing one letter from the end
+! of the string and attaching it to the front. When the user
+! clicks on the text, it should reverse its direction.
+
+CONSTANT: sentence "Hello World! "
+
+TUPLE: animated-label < label-control reversed alarm ;
+
+: <animated-label> ( model -- <animated-model> )
+ sentence animated-label new-label swap >>model
+ monospace-font >>font ;
+
+: update-string ( str reverse -- str )
+ [ unclip-last prefix ] [ unclip suffix ] if ;
+
+: update-model ( model reversed? -- )
+ [ update-string ] curry change-model ;
+
+animated-label
+ H{
+ { T{ button-down } [ [ not ] change-reversed drop ] }
+ } set-gestures
+
+M: animated-label graft*
+ [ [ [ model>> ] [ reversed>> ] bi update-model ] curry 400 milliseconds every ] keep
+ alarm<< ;
+
+M: animated-label ungraft*
+ alarm>> stop-timer ;
+
+: animated-main ( -- )
+ [ sentence <model> <animated-label> "Rosetta" open-window ] with-ui ;
+
+MAIN: animated-main
--- /dev/null
+USING: accessors kernel locals math math.parser peg.ebnf ;
+IN: rosetta-code.arithmetic-evaluation
+
+! http://rosettacode.org/wiki/Arithmetic_evaluation
+
+! Create a program which parses and evaluates arithmetic
+! expressions.
+
+! Requirements
+
+! * An abstract-syntax tree (AST) for the expression must be
+! created from parsing the input.
+! * The AST must be used in evaluation, also, so the input may not
+! be directly evaluated (e.g. by calling eval or a similar
+! language feature.)
+! * The expression will be a string or list of symbols like
+! "(1+3)*7".
+! * The four symbols + - * / must be supported as binary operators
+! with conventional precedence rules.
+! * Precedence-control parentheses must also be supported.
+
+! Note
+
+! For those who don't remember, mathematical precedence is as
+! follows:
+
+! * Parentheses
+! * Multiplication/Division (left to right)
+! * Addition/Subtraction (left to right)
+
+TUPLE: operator left right ;
+TUPLE: add < operator ; C: <add> add
+TUPLE: sub < operator ; C: <sub> sub
+TUPLE: mul < operator ; C: <mul> mul
+TUPLE: div < operator ; C: <div> div
+
+EBNF: expr-ast
+spaces = [\n\t ]*
+digit = [0-9]
+number = (digit)+ => [[ string>number ]]
+
+value = spaces number:n => [[ n ]]
+ | spaces "(" exp:e spaces ")" => [[ e ]]
+
+fac = fac:a spaces "*" value:b => [[ a b <mul> ]]
+ | fac:a spaces "/" value:b => [[ a b <div> ]]
+ | value
+
+exp = exp:a spaces "+" fac:b => [[ a b <add> ]]
+ | exp:a spaces "-" fac:b => [[ a b <sub> ]]
+ | fac
+
+main = exp:e spaces !(.) => [[ e ]]
+;EBNF
+
+GENERIC: eval-ast ( ast -- result )
+
+M: number eval-ast ;
+
+: recursive-eval ( ast -- left-result right-result )
+ [ left>> eval-ast ] [ right>> eval-ast ] bi ;
+
+M: add eval-ast recursive-eval + ;
+M: sub eval-ast recursive-eval - ;
+M: mul eval-ast recursive-eval * ;
+M: div eval-ast recursive-eval / ;
+
+: evaluate ( string -- result )
+ expr-ast eval-ast ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: io formatting locals kernel math sequences unicode.case ;
+IN: rosetta-code.balanced-brackets
+
+! http://rosettacode.org/wiki/Balanced_brackets
+
+! Task:
+
+! Generate a string with N opening brackets (“[”) and N closing
+! brackets (“]”), in some arbitrary order.
+
+! Determine whether the generated string is balanced; that is,
+! whether it consists entirely of pairs of opening/closing
+! brackets (in that order), none of which mis-nest.
+
+! Examples:
+
+! (empty) OK
+! [] OK ][ NOT OK
+! [][] OK ][][ NOT OK
+! [[][]] OK []][[] NOT OK
+
+:: balanced ( str -- )
+ 0 :> counter!
+ 1 :> ok!
+ str
+ [ dup length 0 > ]
+ [ 1 cut swap
+ "[" = [ counter 1 + counter! ] [ counter 1 - counter! ] if
+ counter 0 < [ 0 ok! ] when
+ ]
+ while
+ drop
+ ok 0 =
+ [ "NO" ]
+ [ counter 0 > [ "NO" ] [ "YES" ] if ]
+ if
+ print ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel locals math math.functions math.vectors
+rosetta-code.bitmap rosetta-code.bitmap-line sequences ;
+IN: rosetta-code.bitmap-bezier
+
+! http://rosettacode.org/wiki/Bitmap/Bézier_curves/Cubic
+
+! Using the data storage type defined on this page for raster
+! images, and the draw_line function defined in this other one,
+! draw a cubic bezier curves (definition on Wikipedia).
+
+:: (cubic-bezier) ( P0 P1 P2 P3 -- bezier )
+ [ :> x
+ 1 x - 3 ^ P0 n*v
+ 1 x - sq 3 * x * P1 n*v
+ 1 x - 3 * x sq * P2 n*v
+ x 3 ^ P3 n*v
+ v+ v+ v+ ] ; inline
+
+! gives an interval of x from 0 to 1 to map the bezier function
+: t-interval ( x -- interval )
+ [ iota ] keep 1 - [ / ] curry map ;
+
+! turns a list of points into the list of lines between them
+: points-to-lines ( seq -- seq )
+ dup rest [ 2array ] 2map ;
+
+: draw-lines ( {R,G,B} points image -- )
+ [ [ first2 ] dip draw-line ] curry with each ;
+
+:: bezier-lines ( {R,G,B} P0 P1 P2 P3 image -- )
+ ! 100 is an arbitrary value.. could be given as a parameter..
+ 100 t-interval P0 P1 P2 P3 (cubic-bezier) map
+ points-to-lines
+ {R,G,B} swap image draw-lines ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.functions
+math.ranges math.vectors rosetta-code.bitmap sequences
+ui.gadgets ;
+IN: rosetta-code.bitmap-line
+
+! http://rosettacode.org/wiki/Bitmap/Bresenham%27s_line_algorithm
+
+! Using the data storage type defined on this page for raster
+! graphics images, draw a line given 2 points with the Bresenham's
+! algorithm.
+
+:: line-points ( pt1 pt2 -- points )
+ pt1 first2 :> y0! :> x0!
+ pt2 first2 :> y1! :> x1!
+ y1 y0 - abs x1 x0 - abs > :> steep
+ steep [
+ y0 x0 y0! x0!
+ y1 x1 y1! x1!
+ ] when
+ x0 x1 > [
+ x0 x1 x0! x1!
+ y0 y1 y0! y1!
+ ] when
+ x1 x0 - :> deltax
+ y1 y0 - abs :> deltay
+ 0 :> current-error!
+ deltay deltax / abs :> deltaerr
+ 0 :> ystep!
+ y0 :> y!
+ y0 y1 < [ 1 ystep! ] [ -1 ystep! ] if
+ x0 x1 1 <range> [
+ y steep [ swap ] when 2array
+ current-error deltaerr + current-error!
+ current-error 0.5 >= [
+ ystep y + y!
+ current-error 1 - current-error!
+ ] when
+ ] { } map-as ;
+
+! Needs rosetta-code.bitmap for the set-pixel function and to create the image
+: draw-line ( {R,G,B} pt1 pt2 image -- )
+ [ line-points ] dip
+ [ set-pixel ] curry with each ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry kernel math.matrices sequences ;
+IN: rosetta-code.bitmap
+
+! http://rosettacode.org/wiki/Basic_bitmap_storage
+
+! Show a basic storage type to handle a simple RGB raster
+! graphics image, and some primitive associated functions.
+
+! If possible provide a function to allocate an uninitialised
+! image, given its width and height, and provide 3 additional
+! functions:
+
+! * one to fill an image with a plain RGB color,
+! * one to set a given pixel with a color,
+! * one to get the color of a pixel.
+
+! (If there are specificities about the storage or the
+! allocation, explain those.)
+
+! Various utilities
+: meach ( matrix quot -- ) [ each ] curry each ; inline
+: meach-index ( matrix quot -- )
+ [ swap 2array ] prepose
+ [ curry each-index ] curry each-index ; inline
+: mmap ( matrix quot -- matrix' ) [ map ] curry map ; inline
+: mmap! ( matrix quot -- matrix' ) [ map! ] curry map! ; inline
+: mmap-index ( matrix quot -- matrix' )
+ [ swap 2array ] prepose
+ [ curry map-index ] curry map-index ; inline
+
+: matrix-dim ( matrix -- i j ) [ length ] [ first length ] bi ;
+: set-Mi,j ( elt {i,j} matrix -- ) [ first2 swap ] dip nth set-nth ;
+: Mi,j ( {i,j} matrix -- elt ) [ first2 swap ] dip nth nth ;
+
+! The storage functions
+: <raster-image> ( width height -- image )
+ zero-matrix [ drop { 0 0 0 } ] mmap ;
+: fill-image ( {R,G,B} image -- image )
+ swap '[ drop _ ] mmap! ;
+: set-pixel ( {R,G,B} {i,j} image -- ) set-Mi,j ; inline
+: get-pixel ( {i,j} image -- pixel ) Mi,j ; inline
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators fry grouping hashtables
+kernel locals math math.parser math.ranges random sequences
+strings io ascii ;
+IN: rosetta-code.bulls-and-cows
+
+! http://rosettacode.org/wiki/Bulls_and_cows
+
+! This is an old game played with pencil and paper that was
+! later implemented on computer.
+
+! The task is for the program to create a four digit random
+! number from the digits 1 to 9, without duplication. The program
+! should ask for guesses to this number, reject guesses that are
+! malformed, then print the score for the guess.
+
+! The score is computed as:
+
+! 1. The player wins if the guess is the same as the randomly
+! chosen number, and the program ends.
+
+! 2. A score of one bull is accumulated for each digit in the
+! guess that equals the corresponding digit in the randomly
+! chosen initial number.
+
+! 3. A score of one cow is accumulated for each digit in the
+! guess that also appears in the randomly chosen number, but in
+! the wrong position.
+
+TUPLE: score bulls cows ;
+: <score> ( -- score ) 0 0 score boa ;
+
+TUPLE: cow ;
+: <cow> ( -- cow ) cow new ;
+
+TUPLE: bull ;
+: <bull> ( -- bull ) bull new ;
+
+: inc-bulls ( score -- score ) dup bulls>> 1 + >>bulls ;
+: inc-cows ( score -- score ) dup cows>> 1 + >>cows ;
+
+: random-nums ( -- seq ) 9 [1,b] 4 sample ;
+
+: add-digits ( seq -- n ) 0 [ swap 10 * + ] reduce number>string ;
+
+: new-number ( -- n narr ) random-nums dup add-digits ;
+
+: narr>nhash ( narr -- nhash ) { 1 2 3 4 } swap zip ;
+
+: num>hash ( n -- hash )
+ [ 1string string>number ] { } map-as narr>nhash ;
+
+:: cow-or-bull ( n g -- arr )
+ {
+ { [ n first g at n second = ] [ <bull> ] }
+ { [ n second g value? ] [ <cow> ] }
+ [ f ]
+ } cond ;
+
+: add-to-score ( arr -- score )
+ <score> [ bull? [ inc-bulls ] [ inc-cows ] if ] reduce ;
+
+: check-win ( score -- ? ) bulls>> 4 = ;
+
+: sum-score ( n g -- score ? )
+ '[ _ cow-or-bull ] map sift add-to-score dup check-win ;
+
+: print-sum ( score -- str )
+ dup bulls>> number>string "Bulls: " swap append swap cows>> number>string
+ " Cows: " swap 3append "\n" append ;
+
+: (validate-readln) ( str -- ? ) dup length 4 = not swap [ letter? ] all? or ;
+
+: validate-readln ( -- str )
+ readln dup (validate-readln)
+ [ "Invalid input.\nPlease enter a valid 4 digit number: "
+ write flush drop validate-readln ]
+ when ;
+
+: win ( -- ) "\nYou've won! Good job. You're so smart." print flush ;
+
+: main-loop ( x -- )
+ "Enter a 4 digit number: " write flush validate-readln num>hash swap
+ [ sum-score swap print-sum print flush ] keep swap not
+ [ main-loop ] [ drop win ] if ;
+
+: bulls-and-cows-main ( -- ) new-number drop narr>nhash main-loop ;
+
+MAIN: bulls-and-cows-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: rosetta-code.catalan-numbers
+
+! http://rosettacode.org/wiki/Catalan_numbers
+
+! Catalan numbers are a sequence of numbers which can be defined
+! directly:
+! Cn = 1/(n+1)(2n n) = (2n)! / (n+1)! * n! for n >= 0
+
+! Or recursively:
+! C0 = 1
+! Cn+1 = sum(Ci * Cn-i)) {0..n} for n >= 0
+
+! Or alternatively (also recursive):
+! C0 = 1
+! Cn = (2 * (2n - 1) / (n + 1)) * Cn-1
+
+! Implement at least one of these algorithms and print out the
+! first 15 Catalan numbers with each. Memoization is not required,
+! but may be worth the effort when using the second method above.
+
+: next ( seq -- newseq )
+ [ ] [ last ] [ length ] tri
+ [ 2 * 1 - 2 * ] [ 1 + ] bi /
+ * suffix ;
+
+: catalan ( n -- seq )
+ V{ 1 } swap 1 - [ next ] times ;
--- /dev/null
+USING: kernel rosetta-code.conjugate-transpose tools.test ;
+IN: rosetta-code.conjugate-transpose
+
+{ f t f } [
+ { { C{ 1 2 } 0 } { 0 C{ 3 4 } } }
+ [ hermitian-matrix? ]
+ [ normal-matrix? ]
+ [ unitary-matrix? ] tri
+] unit-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math.functions math.matrices sequences ;
+IN: rosetta-code.conjugate-transpose
+
+! http://rosettacode.org/wiki/Conjugate_transpose
+
+! Suppose that a matrix M contains complex numbers. Then the
+! conjugate transpose of M is a matrix MH containing the complex
+! conjugates of the matrix transposition of M.
+
+! This means that row j, column i of the conjugate transpose
+! equals the complex conjugate of row i, column j of the original
+! matrix.
+
+! In the next list, M must also be a square matrix.
+
+! A Hermitian matrix equals its own conjugate transpose: MH = M.
+
+! A normal matrix is commutative in multiplication with its
+! conjugate transpose: MHM = MMH.
+
+! A unitary matrix has its inverse equal to its conjugate
+! transpose: MH = M − 1. This is true iff MHM = In and iff MMH =
+! In, where In is the identity matrix.
+
+! Given some matrix of complex numbers, find its conjugate
+! transpose. Also determine if it is a Hermitian matrix, normal
+! matrix, or a unitary matrix.
+
+: conj-t ( matrix -- conjugate-transpose )
+ flip [ [ conjugate ] map ] map ;
+
+: hermitian-matrix? ( matrix -- ? )
+ dup conj-t = ;
+
+: normal-matrix? ( matrix -- ? )
+ dup conj-t [ m. ] [ swap m. ] 2bi = ;
+
+: unitary-matrix? ( matrix -- ? )
+ [ dup conj-t m. ] [ length identity-matrix ] bi = ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators io kernel locals math math.functions
+math.ranges prettyprint sequences ;
+IN: rosetta-code.continued-fraction
+
+! http://rosettacode.org/wiki/Continued_fraction
+
+! A number may be represented as a continued fraction (see
+! Mathworld for more information) as follows:
+
+! The task is to write a program which generates such a number
+! and prints a real representation of it. The code should be
+! tested by calculating and printing the square root of 2,
+! Napier's Constant, and Pi, using the following coefficients:
+
+! For the square root of 2, use a0 = 1 then aN = 2. bN is always 1.
+! For Napier's Constant, use a0 = 2, then aN = N. b1 = 1 then bN = N − 1.
+! For Pi, use a0 = 3 then aN = 6. bN = (2N − 1)2.
+
+! Every continued fraction must implement these two words.
+GENERIC: cfrac-a ( n cfrac -- a )
+GENERIC: cfrac-b ( n cfrac -- b )
+
+! square root of 2
+SINGLETON: sqrt2
+M: sqrt2 cfrac-a
+ ! If n is 1, then a_n is 1, else a_n is 2.
+ drop { { 1 [ 1 ] } [ drop 2 ] } case ;
+M: sqrt2 cfrac-b
+ ! Always b_n is 1.
+ 2drop 1 ;
+
+! Napier's constant
+SINGLETON: napier
+M: napier cfrac-a
+ ! If n is 1, then a_n is 2, else a_n is n - 1.
+ drop { { 1 [ 2 ] } [ 1 - ] } case ;
+M: napier cfrac-b
+ ! If n is 1, then b_n is 1, else b_n is n - 1.
+ drop { { 1 [ 1 ] } [ 1 - ] } case ;
+
+SINGLETON: pi
+M: pi cfrac-a
+ ! If n is 1, then a_n is 3, else a_n is 6.
+ drop { { 1 [ 3 ] } [ drop 6 ] } case ;
+M: pi cfrac-b
+ ! Always b_n is (n * 2 - 1)^2.
+ drop 2 * 1 - 2 ^ ;
+
+:: cfrac-estimate ( cfrac terms -- number )
+ terms cfrac cfrac-a ! top = last a_n
+ terms 1 - 1 [a,b] [ :> n
+ n cfrac cfrac-b swap / ! top = b_n / top
+ n cfrac cfrac-a + ! top = top + a_n
+ ] each ;
+
+:: decimalize ( rational prec -- string )
+ rational 1 /mod ! split whole, fractional parts
+ prec 10^ * ! multiply fraction by 10 ^ prec
+ [ >integer unparse ] bi@ ! convert digits to strings
+ :> fraction
+ "." ! push decimal point
+ prec fraction length -
+ dup 0 < [ drop 0 ] when
+ "0" <repetition> concat ! push padding zeros
+ fraction 4array concat ;
+
+<PRIVATE
+: main ( -- )
+ " Square root of 2: " write
+ sqrt2 50 cfrac-estimate 30 decimalize print
+ "Napier's constant: " write
+ napier 50 cfrac-estimate 30 decimalize print
+ " Pi: " write
+ pi 950 cfrac-estimate 10 decimalize print ;
+PRIVATE>
+
+MAIN: main
--- /dev/null
+
+USING: tools.test ;
+
+IN: rosetta-code.count-the-coins
+
+{ 242 } [ 100 { 25 10 5 1 } make-change ] unit-test
+{ 13398445413854501 } [ 100000 { 100 50 25 10 5 1 } make-change ] unit-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays locals math math.ranges sequences sets sorting ;
+IN: rosetta-code.count-the-coins
+
+! http://rosettacode.org/wiki/Count_the_coins
+
+! There are four types of common coins in US currency: quarters
+! (25 cents), dimes (10), nickels (5) and pennies (1). There are 6
+! ways to make change for 15 cents:
+
+! A dime and a nickel;
+! A dime and 5 pennies;
+! 3 nickels;
+! 2 nickels and 5 pennies;
+! A nickel and 10 pennies;
+! 15 pennies.
+
+! How many ways are there to make change for a dollar using
+! these common coins? (1 dollar = 100 cents).
+
+! Optional:
+
+! Less common are dollar coins (100 cents); very rare are half
+! dollars (50 cents). With the addition of these two coins, how
+! many ways are there to make change for $1000? (note: the answer
+! is larger than 232).
+
+<PRIVATE
+
+:: (make-change) ( cents coins -- ways )
+ cents 1 + 0 <array> :> ways
+ 1 ways set-first
+ coins [| coin |
+ coin cents [a,b] [| j |
+ j coin - ways nth j ways [ + ] change-nth
+ ] each
+ ] each ways last ;
+
+PRIVATE>
+
+! How many ways can we make the given amount of cents
+! with the given set of coins?
+: make-change ( cents coins -- ways )
+ members [ ] inv-sort-with (make-change) ;
--- /dev/null
+USING: tools.test ;
+IN: rosetta-code.equilibrium-index
+
+{ V{ 3 6 } } [ { -7 1 5 2 -4 3 0 } equilibrium-indices ] unit-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: rosetta-code.equilibrium-index
+
+! http://rosettacode.org/wiki/Equilibrium_index
+
+! An equilibrium index of a sequence is an index into the sequence such that the sum of elements at lower indices is equal to the sum of elements at higher indices. For example, in a sequence A:
+! A0 = − 7
+! A1 = 1
+! A2 = 5
+! A3 = 2
+! A4 = − 4
+! A5 = 3
+! A6 = 0
+
+! 3 is an equilibrium index, because:
+! A0 + A1 + A2 = A4 + A5 + A6
+
+! 6 is also an equilibrium index, because:
+! A0 + A1 + A2 + A3 + A4 + A5 = 0
+! (sum of zero elements is zero)
+
+! 7 is not an equilibrium index, because it is not a valid index
+! of sequence A.
+
+! Write a function that, given a sequence, returns its
+! equilibrium indices (if any). Assume that the sequence may be
+! very long.
+
+: accum-left ( seq id quot -- seq )
+ accumulate nip ; inline
+
+: accum-right ( seq id quot -- seq )
+ [ <reversed> ] 2dip accum-left <reversed> ; inline
+
+: equilibrium-indices ( seq -- inds )
+ 0 [ + ] [ accum-left ] [ accum-right ] 3bi [ = ] 2map
+ V{ } swap dup length iota [ [ suffix ] curry [ ] if ] 2each ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel math math.functions math.parser math.ranges
+sequences ;
+IN: rosetta-code.fizzbuzz
+
+: fizz ( n -- str ) 3 divisor? "Fizz" "" ? ;
+
+: buzz ( n -- str ) 5 divisor? "Buzz" "" ? ;
+
+: fizzbuzz ( n -- str )
+ dup [ fizz ] [ buzz ] bi append [ number>string ] [ nip ] if-empty ;
+
+: fizzbuzz-main ( -- )
+ 100 [1,b] [ fizzbuzz print ] each ;
+
+MAIN: fizzbuzz-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel locals math math.parser math.ranges
+prettyprint sequences ;
+IN: rosetta-code.gray-code
+
+! http://rosettacode.org/wiki/Gray_code
+
+! Gray code is a form of binary encoding where transitions
+! between consecutive numbers differ by only one bit. This is a
+! useful encoding for reducing hardware data hazards with values
+! that change rapidly and/or connect to slower hardware as inputs.
+! It is also useful for generating inputs for Karnaugh maps in
+! order from left to right or top to bottom.
+
+! Create functions to encode a number to and decode a number
+! from Gray code. Display the normal binary representations, Gray
+! code representations, and decoded Gray code values for all 5-bit
+! binary numbers (0-31 inclusive, leading 0's not necessary).
+
+! There are many possible Gray codes. The following encodes what
+! is called "binary reflected Gray code."
+
+! Encoding (MSB is bit 0, b is binary, g is Gray code):
+! if b[i-1] = 1
+! g[i] = not b[i]
+! else
+! g[i] = b[i]
+
+! Or:
+! g = b xor (b logically right shifted 1 time)
+
+! Decoding (MSB is bit 0, b is binary, g is Gray code):
+! b[0] = g[0]
+! b[i] = g[i] xor b[i-1]
+
+: gray-encode ( n -- n' ) dup -1 shift bitxor ;
+
+:: gray-decode ( n! -- n' )
+ n :> p!
+ [ n -1 shift dup n! 0 = not ] [
+ p n bitxor p!
+ ] while
+ p ;
+
+: gray-code-main ( -- )
+ -1 32 [a,b] [
+ dup [ >bin ] [ gray-encode ] bi
+ [ >bin ] [ gray-decode ] bi 4array .
+ ] each ;
+
+MAIN: gray-code-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io kernel math math.ranges prettyprint sequences vectors ;
+IN: rosetta-code.hailstone-sequence
+
+! http://rosettacode.org/wiki/Hailstone_sequence
+
+! The Hailstone sequence of numbers can be generated from a
+! starting positive integer, n by:
+
+! * If n is 1 then the sequence ends.
+! * If n is even then the next n of the sequence = n/2
+! * If n is odd then the next n of the sequence = (3 * n) + 1
+
+! The (unproven), Collatz conjecture is that the hailstone
+! sequence for any starting number always terminates.
+
+! Task Description:
+
+! 1. Create a routine to generate the hailstone sequence for a
+! number.
+
+! 2. Use the routine to show that the hailstone sequence for the
+! number 27 has 112 elements starting with 27, 82, 41, 124 and
+! ending with 8, 4, 2, 1
+
+! 3. Show the number less than 100,000 which has the longest
+! hailstone sequence together with that sequences length.
+! (But don't show the actual sequence)!
+
+: hailstone ( n -- seq )
+ [ 1vector ] keep
+ [ dup 1 number= ]
+ [
+ dup even? [ 2 / ] [ 3 * 1 + ] if
+ 2dup swap push
+ ] until
+ drop ;
+
+: hailstone-main ( -- )
+ 27 hailstone dup dup
+ "The hailstone sequence from 27:" print
+ " has length " write length .
+ " starts with " write 4 head [ unparse ] map ", " join print
+ " ends with " write 4 tail* [ unparse ] map ", " join print
+
+ ! Maps n => { length n }, and reduces to longest Hailstone sequence.
+ 1 100000 [a,b)
+ [ [ hailstone length ] keep 2array ]
+ [ [ [ first ] bi@ > ] most ] map-reduce
+ first2
+ "The hailstone sequence from " write pprint
+ " has length " write pprint "." print ;
+
+MAIN: hailstone-main
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel lists lists.lazy locals math ;
+IN: rosetta-code.hamming-lazy
+
+! http://rosettacode.org/wiki/Hamming_numbers#Factor
+
+! Hamming numbers are numbers of the form
+! H = 2^i * 3^j * 5^k where i, j, k >= 0
+
+! Hamming numbers are also known as ugly numbers and also
+! 5-smooth numbers (numbers whose prime divisors are less or equal
+! to 5).
+
+! Generate the sequence of Hamming numbers, in increasing order.
+! In particular:
+
+! 1. Show the first twenty Hamming numbers.
+! 2. Show the 1691st Hamming number (the last one below 231).
+! 3. Show the one millionth Hamming number (if the language – or
+! a convenient library – supports arbitrary-precision integers).
+
+:: sort-merge ( xs ys -- result )
+ xs car :> x
+ ys car :> y
+ {
+ { [ x y < ] [ [ x ] [ xs cdr ys sort-merge ] lazy-cons ] }
+ { [ x y > ] [ [ y ] [ ys cdr xs sort-merge ] lazy-cons ] }
+ [ [ x ] [ xs cdr ys cdr sort-merge ] lazy-cons ]
+ } cond ;
+
+:: hamming ( -- hamming )
+ f :> h!
+ [ 1 ] [
+ h 2 3 5 [ '[ _ * ] lazy-map ] tri-curry@ tri
+ sort-merge sort-merge
+ ] lazy-cons h! h ;
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors deques dlists fry kernel make math math.order ;
+IN: rosetta-code.hamming
+
+! http://rosettacode.org/wiki/Hamming_numbers#Factor
+
+! Hamming numbers are numbers of the form
+! H = 2^i * 3^j * 5^k where i, j, k >= 0
+
+! Hamming numbers are also known as ugly numbers and also
+! 5-smooth numbers (numbers whose prime divisors are less or equal
+! to 5).
+
+! Generate the sequence of Hamming numbers, in increasing order.
+! In particular:
+
+! 1. Show the first twenty Hamming numbers.
+! 2. Show the 1691st Hamming number (the last one below 231).
+! 3. Show the one millionth Hamming number (if the language – or
+! a convenient library – supports arbitrary-precision integers).
+
+TUPLE: hamming-iterator 2s 3s 5s ;
+
+: <hamming-iterator> ( -- hamming-iterator )
+ hamming-iterator new
+ 1 1dlist >>2s
+ 1 1dlist >>3s
+ 1 1dlist >>5s ;
+
+: enqueue ( n hamming-iterator -- )
+ [ [ 2 * ] [ 2s>> ] bi* push-back ]
+ [ [ 3 * ] [ 3s>> ] bi* push-back ]
+ [ [ 5 * ] [ 5s>> ] bi* push-back ] 2tri ;
+
+: next ( hamming-iterator -- n )
+ dup [ 2s>> ] [ 3s>> ] [ 5s>> ] tri
+ 3dup [ peek-front ] tri@ min min
+ [
+ '[
+ dup peek-front _ =
+ [ pop-front* ] [ drop ] if
+ ] tri@
+ ] [ swap enqueue ] [ ] tri ;
+
+: next-n ( hamming-iterator n -- seq )
+ swap '[ _ [ _ next , ] times ] { } make ;
+
+: nth-from-now ( hamming-iterator n -- m )
+ 1 - over '[ _ next drop ] times next ;
--- /dev/null
+USING: tools.test ;
+IN: rosetta-code.happy-numbers
+
+{ { 1 7 10 13 19 23 28 31 } } [ 8 happy-numbers ] unit-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel make math sequences ;
+IN: rosetta-code.happy-numbers
+
+! http://rosettacode.org/wiki/Happy_numbers#Factor
+
+! From Wikipedia, the free encyclopedia:
+
+! A happy number is defined by the following process. Starting
+! with any positive integer, replace the number by the sum of the
+! squares of its digits, and repeat the process until the number
+! equals 1 (where it will stay), or it loops endlessly in a cycle
+! which does not include 1. Those numbers for which this process
+! ends in 1 are happy numbers, while those that do not end in 1
+! are unhappy numbers. Display an example of your output here.
+
+! Task: Find and print the first 8 happy numbers.
+
+: squares ( n -- s )
+ 0 [ over 0 > ] [ [ 10 /mod sq ] dip + ] while nip ;
+
+: (happy?) ( n1 n2 -- ? )
+ [ squares ] [ squares squares ] bi* {
+ { [ dup 1 = ] [ 2drop t ] }
+ { [ 2dup = ] [ 2drop f ] }
+ [ (happy?) ]
+ } cond ;
+
+: happy? ( n -- ? )
+ dup (happy?) ;
+
+: happy-numbers ( n -- seq )
+ [
+ 0 [ over 0 > ] [
+ dup happy? [ dup , [ 1 - ] dip ] when 1 +
+ ] while 2drop
+ ] { } make ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.constants math.functions
+math.vectors sequences ;
+IN: rosetta-code.haversine-formula
+
+! http://rosettacode.org/wiki/Haversine_formula
+
+! The haversine formula is an equation important in navigation,
+! giving great-circle distances between two points on a sphere
+! from their longitudes and latitudes. It is a special case of a
+! more general formula in spherical trigonometry, the law of
+! haversines, relating the sides and angles of spherical
+! "triangles".
+
+! Task: Implement a great-circle distance function, or use a
+! library function, to show the great-circle distance between
+! Nashville International Airport (BNA) in Nashville, TN, USA: N
+! 36°7.2', W 86°40.2' (36.12, -86.67) and Los Angeles
+! International Airport (LAX) in Los Angeles, CA, USA: N 33°56.4',
+! W 118°24.0' (33.94, -118.40).
+
+CONSTANT: R_earth 6372.8 ! in kilometers
+
+: haversin ( x -- y ) cos 1 swap - 2 / ;
+
+: haversininv ( y -- x ) 2 * 1 swap - acos ;
+
+: haversineDist ( as bs -- d )
+ [ [ 180 / pi * ] map ] bi@
+ [ [ swap - haversin ] 2map ]
+ [ [ first cos ] bi@ * 1 swap 2array ]
+ 2bi
+ v.
+ haversininv R_earth * ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces sequences ;
+IN: rosetta-code.hofstadter-ffs
+
+! These two sequences of positive integers are defined as:
+! R(1) = 1 ; S(1) = 1
+! R(n) = R(n-1) + S(n-1) , n > 1
+! The sequence S(n) is further defined as the sequence of
+! positive integers not present in R(n).
+
+! Sequence R starts: 1, 3, 7, 12, 18, ...
+! Sequence S starts: 2, 4, 5, 6, 8, ...
+
+! Task:
+
+! 1. Create two functions named ffr and ffs that when given n
+! return R(n) or S(n) respectively.
+! (Note that R(1) = 1 and S(1) = 2 to avoid off-by-one errors).
+! 2. No maximum value for n should be assumed.
+! 3. Calculate and show that the first ten values of R are: 1,
+! 3, 7, 12, 18, 26, 35, 45, 56, and 69
+! 4. Calculate and show that the first 40 values of ffr plus the
+! first 960 values of ffs include all the integers from 1 to 1000
+! exactly once.
+
+SYMBOL: S V{ 2 } S set
+SYMBOL: R V{ 1 } R set
+
+: next ( s r -- news newr )
+ 2dup [ last ] bi@ + suffix
+ dup [
+ [ dup last 1 + dup ] dip member? [ 1 + ] when suffix
+ ] dip ;
+
+: inc-SR ( n -- )
+ dup 0 <=
+ [ drop ]
+ [ [ S get R get ] dip [ next ] times R set S set ]
+ if ;
+
+: ffs ( n -- S(n) )
+ dup S get length - inc-SR
+ 1 - S get nth ;
+
+: ffr ( n -- R(n) )
+ dup R get length - inc-SR
+ 1 - R get nth ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math prettyprint sequences ;
+IN: rosetta-code.hofstadter-q
+
+! http://rosettacode.org/wiki/Hofstadter_Q_sequence
+
+! The Hofstadter Q sequence is defined as:
+! Q(1) = Q(2) = 1
+! Q(n) = Q(n - Q(n-1)) + Q(n - Q(n-2)) , n > 2
+
+! It is defined like the Fibonacci sequence, but whereas the
+! next term in the Fibonacci sequence is the sum of the previous
+! two terms, in the Q sequence the previous two terms tell you how
+! far to go back in the Q sequence to find the two numbers to sum
+! to make the next term of the sequence.
+
+! Task
+
+! 1. Confirm and display that the first ten terms of the sequence
+! are: 1, 1, 2, 3, 3, 4, 5, 5, 6, and 6
+
+! 2. Confirm and display that the 1000'th term is: 502
+
+! Optional extra credit
+
+! * Count and display how many times a member of the sequence is
+! less than its preceding term for terms up to and including the
+! 100,000'th term.
+
+! * Ensure that the extra credit solution 'safely' handles being
+! initially asked for an n'th term where n is large.
+
+! (This point is to ensure that caching and/or recursion limits,
+! if it is a concern, is correctly handled).
+
+ : next ( seq -- newseq )
+ dup 2 tail* over length [ swap - ] curry map
+ [ dupd swap nth ] map 0 [ + ] reduce suffix ;
+
+: qs-main ( -- )
+ { 1 1 } 1000 [ next ] times dup 10 head . 999 swap nth . ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs fry io.encodings.utf8 io.files kernel sequences
+sets splitting vectors ;
+IN: rosetta-code.inverted-index
+
+! http://rosettacode.org/wiki/Inverted_index
+
+! An Inverted Index is a data structure used to create full text
+! search.
+
+! Given a set of text files, implement a program to create an
+! inverted index. Also create a user interface to do a search
+! using that inverted index which returns a list of files that
+! contain the query term / terms. The search index can be in
+! memory.
+
+: file-words ( file -- assoc )
+ utf8 file-contents " ,;:!?.()[]{}\n\r" split harvest ;
+
+: add-to-file-list ( files file -- files )
+ over [ swap [ adjoin ] keep ] [ nip 1vector ] if ;
+
+: add-to-index ( words index file -- )
+ '[ _ [ _ add-to-file-list ] change-at ] each ;
+
+: (index-files) ( files index -- )
+ [ [ [ file-words ] keep ] dip swap add-to-index ] curry each ;
+
+: index-files ( files -- index )
+ H{ } clone [ (index-files) ] keep ;
+
+: query ( terms index -- files )
+ [ at ] curry map [ ] [ intersect ] map-reduce ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel locals math math.order
+math.vectors sequences sequences.product combinators.short-circuit ;
+IN: rosetta-code.knapsack-unbounded
+
+! http://rosettacode.org/wiki/Knapsack_problem/Unbounded
+
+! A traveller gets diverted and has to make an unscheduled stop
+! in what turns out to be Shangri La. Opting to leave, he is
+! allowed to take as much as he likes of the following items, so
+! long as it will fit in his knapsack, and he can carry it. He
+! knows that he can carry no more than 25 'weights' in total; and
+! that the capacity of his knapsack is 0.25 'cubic lengths'.
+
+! Looking just above the bar codes on the items he finds their
+! weights and volumes. He digs out his recent copy of a financial
+! paper and gets the value of each item.
+
+! He can only take whole units of any item, but there is much
+! more of any item than he could ever carry
+
+! How many of each item does he take to maximise the value of
+! items he is carrying away with him?
+
+! Note:
+
+! There are four solutions that maximise the value taken. Only
+! one need be given.
+
+CONSTANT: values { 3000 1800 2500 }
+CONSTANT: weights { 0.3 0.2 2.0 }
+CONSTANT: volumes { 0.025 0.015 0.002 }
+
+CONSTANT: max-weight 25.0
+CONSTANT: max-volume 0.25
+
+TUPLE: bounty amounts value weight volume ;
+
+: <bounty> ( items -- bounty )
+ [ bounty new ] dip {
+ [ >>amounts ]
+ [ values v. >>value ]
+ [ weights v. >>weight ]
+ [ volumes v. >>volume ]
+ } cleave ;
+
+: valid-bounty? ( bounty -- ? )
+ { [ weight>> max-weight <= ]
+ [ volume>> max-volume <= ] } 1&& ;
+
+M:: bounty <=> ( a b -- <=> )
+ a valid-bounty? [
+ b valid-bounty? [
+ a b [ value>> ] compare
+ ] [ +gt+ ] if
+ ] [ b valid-bounty? +lt+ +eq+ ? ] if ;
+
+: find-max-amounts ( -- amounts )
+ weights volumes [
+ [ max-weight swap / ]
+ [ max-volume swap / ] bi* min >integer
+ ] 2map ;
+
+: best-bounty ( -- bounty )
+ find-max-amounts [ 1 + iota ] map <product-sequence>
+ [ <bounty> ] [ max ] map-reduce ;
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry io kernel locals make math
+math.order math.parser math.ranges sequences sorting ;
+IN: rosetta-code.knapsack
+
+! http://rosettacode.org/wiki/Knapsack_problem/0-1
+
+! A tourist wants to make a good trip at the weekend with his
+! friends. They will go to the mountains to see the wonders of
+! nature, so he needs to pack well for the trip. He has a good
+! knapsack for carrying things, but knows that he can carry a
+! maximum of only 4kg in it and it will have to last the whole
+! day. He creates a list of what he wants to bring for the trip
+! but the total weight of all items is too much. He then decides
+! to add columns to his initial list detailing their weights and a
+! numerical value representing how important the item is for the
+! trip.
+
+! The tourist can choose to take any combination of items from
+! the list, but only one of each item is available. He may not cut
+! or diminish the items, so he can only take whole units of any
+! item.
+
+! Which items does the tourist carry in his knapsack so that
+! their total weight does not exceed 400 dag [4 kg], and their
+! total value is maximised?
+
+TUPLE: item
+ name weight value ;
+
+CONSTANT: items {
+ T{ item f "map" 9 150 }
+ T{ item f "compass" 13 35 }
+ T{ item f "water" 153 200 }
+ T{ item f "sandwich" 50 160 }
+ T{ item f "glucose" 15 60 }
+ T{ item f "tin" 68 45 }
+ T{ item f "banana" 27 60 }
+ T{ item f "apple" 39 40 }
+ T{ item f "cheese" 23 30 }
+ T{ item f "beer" 52 10 }
+ T{ item f "suntan cream" 11 70 }
+ T{ item f "camera" 32 30 }
+ T{ item f "t-shirt" 24 15 }
+ T{ item f "trousers" 48 10 }
+ T{ item f "umbrella" 73 40 }
+ T{ item f "waterproof trousers" 42 70 }
+ T{ item f "waterproof overclothes" 43 75 }
+ T{ item f "note-case" 22 80 }
+ T{ item f "sunglasses" 7 20 }
+ T{ item f "towel" 18 12 }
+ T{ item f "socks" 4 50 }
+ T{ item f "book" 30 10 }
+ }
+
+CONSTANT: limit 400
+
+: make-table ( -- table )
+ items length 1 + [ limit 1 + 0 <array> ] replicate ;
+
+:: iterate ( item-no table -- )
+ item-no table nth :> prev
+ item-no 1 + table nth :> curr
+ item-no items nth :> item
+ limit [1,b] [| weight |
+ weight prev nth
+ weight item weight>> - dup 0 >=
+ [ prev nth item value>> + max ]
+ [ drop ] if
+ weight curr set-nth
+ ] each ;
+
+: fill-table ( table -- )
+ [ items length iota ] dip
+ '[ _ iterate ] each ;
+
+:: extract-packed-items ( table -- items )
+ [
+ limit :> weight!
+ items length iota <reversed> [| item-no |
+ item-no table nth :> prev
+ item-no 1 + table nth :> curr
+ weight [ curr nth ] [ prev nth ] bi =
+ [
+ item-no items nth
+ [ name>> , ] [ weight>> weight swap - weight! ] bi
+ ] unless
+ ] each
+ ] { } make ;
+
+: solve-knapsack ( -- items value )
+ make-table [ fill-table ]
+ [ extract-packed-items ] [ last last ] tri ;
+
+: knapsack-main ( -- )
+ solve-knapsack
+ "Total value: " write number>string print
+ "Items packed: " print
+ natural-sort
+ [ " " write print ] each ;
+
+MAIN: knapsack-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: rosetta-code.long-multiplication
+
+! http://rosettacode.org/wiki/Long_multiplication
+
+! In this task, explicitly implement long multiplication. This
+! is one possible approach to arbitrary-precision integer algebra.
+
+! For output, display the result of 2^64 * 2^64. The decimal
+! representation of 2^64 is:
+
+! 18446744073709551616
+
+! The output of 2^64 * 2^64 is 2^128, and that is:
+
+! 340282366920938463463374607431768211456
+
+: longmult-seq ( xs ys -- zs )
+ [ * ] cartesian-map
+ dup length iota [ 0 <repetition> ] map
+ [ prepend ] 2map
+ [ ] [ [ 0 suffix ] dip [ + ] 2map ] map-reduce ;
+
+: integer->digits ( x -- xs )
+ { } swap [ dup 0 > ] [ 10 /mod swap [ prefix ] dip ] while drop ;
+
+: digits->integer ( xs -- x )
+ 0 [ swap 10 * + ] reduce ;
+
+: longmult ( x y -- z )
+ [ integer->digits ] bi@ longmult-seq digits->integer ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel make math math.parser sequences ;
+IN: rosetta-code.look-and-say
+
+! http://rosettacode.org/wiki/Look-and-say_sequence
+
+! Sequence Definition
+! * Take a decimal number
+! * Look at the number, visually grouping consecutive runs of
+! the same digit.
+! * Say the number, from left to right, group by group; as how
+! many of that digit there are - followed by the digit grouped.
+! This becomes the next number of the sequence.
+
+! The sequence is from John Conway, of Conway's Game of Life fame.
+
+! An example:
+! * Starting with the number 1, you have one 1 which produces 11.
+! * Starting with 11, you have two 1's i.e. 21
+! * Starting with 21, you have one 2, then one 1 i.e. (12)(11) which becomes 1211
+! * Starting with 1211 you have one 1, one 2, then two 1's i.e. (11)(12)(21) which becomes 111221
+
+! Task description
+
+! Write a program to generate successive members of the look-and-say sequence.
+
+: (look-and-say) ( str -- )
+ unclip-slice swap [ 1 ] 2dip [
+ 2dup = [ drop [ 1 + ] dip ] [
+ [ [ number>string % ] dip , 1 ] dip
+ ] if
+ ] each [ number>string % ] [ , ] bi* ;
+
+: look-and-say ( str -- str' )
+ [ (look-and-say) ] "" make ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.parser math.order math.ranges sequences ;
+IN: rosetta-code.luhn-test
+
+! http://rosettacode.org/wiki/Luhn_test_of_credit_card_numbers
+
+! The Luhn test is used by some credit card companies to
+! distinguish valid credit card numbers from what could be a
+! random selection of digits.
+
+! Those companies using credit card numbers that can be
+! validated by the Luhn test have numbers that pass the following
+! test:
+
+! 1. Reverse the order of the digits in the number.
+
+! 2. Take the first, third, ... and every other odd digit in the
+! reversed digits and sum them to form the partial sum s1
+
+! 3. Taking the second, fourth ... and every other even digit in
+! the reversed digits:
+! a. Multiply each digit by two and sum the digits if the
+! answer is greater than nine to form partial sums for the
+! even digits
+! b. Sum the partial sums of the even digits to form s2
+
+! 4. If s1 + s2 ends in zero then the original number is in the
+! form of a valid credit card number as verified by the Luhn test.
+
+! For example, if the trial number is 49927398716:
+
+! Reverse the digits:
+! 61789372994
+! Sum the odd digits:
+! 6 + 7 + 9 + 7 + 9 + 4 = 42 = s1
+! The even digits:
+! 1, 8, 3, 2, 9
+! Two times each even digit:
+! 2, 16, 6, 4, 18
+! Sum the digits of each multiplication:
+! 2, 7, 6, 4, 9
+! Sum the last:
+! 2 + 7 + 6 + 4 + 9 = 28 = s2
+
+! s1 + s2 = 70 which ends in zero which means that 49927398716
+! passes the Luhn test
+
+! The task is to write a function/method/procedure/subroutine
+! that will validate a number with the Luhn test, and use it to
+! validate the following numbers:
+! 49927398716
+! 49927398717
+! 1234567812345678
+! 1234567812345670
+
+: reversed-digits ( n -- list )
+ { } swap
+ [ dup 0 > ]
+ [ 10 /mod swapd suffix swap ]
+ while drop ;
+
+: luhn-digit ( n -- n )
+ reversed-digits dup length iota [
+ 2dup swap nth
+ swap odd? [ 2 * 10 /mod + ] when
+ ] map sum 10 mod
+ nip ;
+
+: luhn? ( n -- ? )
+ luhn-digit 0 = ;
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: formatting io kernel math math.parser sequences ;
+IN: rosetta-code.menu
+
+! http://rosettacode.org/wiki/Menu
+
+! Given a list containing a number of strings of which one is to
+! be selected and a prompt string, create a function that:
+
+! * Print a textual menu formatted as an index value followed by
+! its corresponding string for each item in the list.
+! * Prompt the user to enter a number.
+! * Return the string corresponding to the index number.
+
+! The function should reject input that is not an integer or is
+! an out of range integer index by recreating the whole menu
+! before asking again for a number. The function should return an
+! empty string if called with an empty list.
+
+! For test purposes use the four phrases: “fee fie”, “huff and
+! puff”, “mirror mirror” and “tick tock” in a list.
+
+! Note: This task is fashioned after the action of the Bash select statement.
+
+: print-menu ( seq -- )
+ [ 1 + swap "%d - %s\n" printf ] each-index
+ "Your choice? " write flush ;
+
+: select ( seq -- result )
+ dup print-menu
+ readln string>number [
+ 1 - swap 2dup bounds-check?
+ [ nth ] [ nip select ] if
+ ] [ select ] if* ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel math math.parser math.ranges sequences ;
+IN: rosetta-code.multiplication-tables
+
+! http://rosettacode.org/wiki/Multiplication_tables
+
+! Produce a formatted 12×12 multiplication table of the kind
+! memorised by rote when in primary school.
+
+! Only print the top half triangle of products.
+
+: print-row ( n -- )
+ [ number>string 2 CHAR: space pad-head write " |" write ]
+ [ 1 - [ " " write ] times ]
+ [
+ dup 12 [a,b]
+ [ * number>string 4 CHAR: space pad-head write ] with each
+ ] tri nl ;
+
+: print-table ( -- )
+ " " write
+ 1 12 [a,b] [ number>string 4 CHAR: space pad-head write ] each nl
+ " +" write
+ 12 [ "----" write ] times nl
+ 1 12 [a,b] [ print-row ] each ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math math.combinatorics formatting io locals ;
+IN: rosetta-code.n-queens
+
+! http://rosettacode.org/wiki/N-queens_problem
+
+! Solve the eight queens puzzle. You can extend the problem to
+! solve the puzzle with a board of side NxN.
+
+:: safe? ( board q -- ? )
+ [let q board nth :> x
+ q iota [
+ x swap
+ [ board nth ] keep
+ q swap -
+ [ + = not ]
+ [ - = not ] 3bi and
+ ] all?
+ ] ;
+
+: solution? ( board -- ? )
+ dup length iota [ dupd safe? ] all? nip ;
+
+: queens ( n -- l )
+ iota all-permutations [ solution? ] filter ;
+
+: queens. ( n -- )
+ queens [ [ 1 + "%d " printf ] each nl ] each ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: formatting io kernel math math.parser math.ranges
+namespaces random sequences strings ;
+IN: rosetta-code.number-reversal
+
+! http://rosettacode.org/wiki/Number_reversal_game
+
+! Given a jumbled list of the numbers 1 to 9 that are definitely
+! not in ascending order, show the list then ask the player how
+! many digits from the left to reverse. Reverse those digits, then
+! ask again, until all the digits end up in ascending order.
+
+! The score is the count of the reversals needed to attain the
+! ascending order.
+
+! Note: Assume the players input does not need extra validation.
+
+: make-jumbled-array ( -- sorted jumbled )
+ CHAR: 1 CHAR: 9 [a,b] [ 1string ] map dup clone randomize
+ [ 2dup = ] [ randomize ] while ;
+
+SYMBOL: trials
+
+: prompt ( jumbled -- n )
+ trials get "#%2d: " printf
+ ", " join write
+ " Flip how many? " write flush
+ readln string>number ;
+
+: game-loop ( sorted jumbled -- )
+ 2dup = [
+ 2drop trials get
+ "\nYou took %d attempts to put the digits in order!\n" printf
+ flush
+ ] [
+ trials [ 1 + ] change
+ dup dup prompt head-slice reverse! drop
+ game-loop
+ ] if ;
+
+: play ( -- )
+ 0 trials set
+ make-jumbled-array game-loop ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations kernel io io.streams.string locals unicode.categories ;
+IN: rosetta-code.odd-word
+
+! http://rosettacode.org/wiki/Odd_word_problem
+
+! Write a program that solves the odd word problem with the
+! restrictions given below.
+
+! Description: You are promised an input stream consisting of
+! English letters and punctuations. It is guaranteed that
+
+! * the words (sequence of consecutive letters) are delimited by
+! one and only one punctuation; that
+! * the stream will begin with a word; that
+! * the words will be at least one letter long; and that
+! * a full stop (.) appears after, and only after, the last word.
+
+! For example, what,is,the;meaning,of:life. is such a stream
+! with six words. Your task is to reverse the letters in every
+! other word while leaving punctuations intact, producing e.g.
+! "what,si,the;gninaem,of:efil.", while observing the following
+! restrictions:
+
+! Only I/O allowed is reading or writing one character at a
+! time, which means: no reading in a string, no peeking ahead, no
+! pushing characters back into the stream, and no storing
+! characters in a global variable for later use;
+
+! You are not to explicitly save characters in a collection data
+! structure, such as arrays, strings, hash tables, etc, for later
+! reversal;
+
+! You are allowed to use recursions, closures, continuations,
+! threads, coroutines, etc., even if their use implies the storage
+! of multiple characters.
+
+! Test case: work on both the "life" example given above, and
+! the text we,are;not,in,kansas;any,more.
+
+<PRIVATE
+! Save current continuation.
+: savecc ( -- continuation/f )
+ [ ] callcc1 ; inline
+
+! Jump back to continuation, where savecc will return f.
+: jump-back ( continuation -- )
+ f swap continue-with ; inline
+PRIVATE>
+
+:: read-odd-word ( -- )
+ f :> first-continuation!
+ f :> last-continuation!
+ f :> reverse!
+ ! Read characters. Loop until end of stream.
+ [ read1 dup ] [
+ dup Letter? [
+ ! This character is a letter.
+ reverse [
+ ! Odd word: Write letters in reverse order.
+ last-continuation savecc dup [
+ last-continuation!
+ 2drop ! Drop letter and previous continuation.
+ ] [
+ ! After jump: print letters in reverse.
+ drop ! Drop f.
+ swap write1 ! Write letter.
+ jump-back ! Follow chain of continuations.
+ ] if
+ ] [
+ ! Even word: Write letters immediately.
+ write1
+ ] if
+ ] [
+ ! This character is punctuation.
+ reverse [
+ ! End odd word. Fix trampoline, follow chain of continuations
+ ! (to print letters in reverse), then bounce off trampoline.
+ savecc dup [
+ first-continuation!
+ last-continuation jump-back
+ ] [ drop ] if
+ write1 ! Write punctuation.
+ f reverse! ! Begin even word.
+ ] [
+ write1 ! Write punctuation.
+ t reverse! ! Begin odd word.
+ ! Create trampoline to bounce to (future) first-continuation.
+ savecc dup [
+ last-continuation!
+ ] [ drop first-continuation jump-back ] if
+ ] if
+ ] if
+ ] while
+ ! Drop f from read1. Then print a cosmetic newline.
+ drop nl ;
+
+: odd-word ( string -- )
+ [ read-odd-word ] with-string-reader ;
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: bit-arrays io kernel locals math sequences ;
+IN: rosetta-code.one-d-cellular
+
+! http://rosettacode.org/wiki/One-dimensional_cellular_automata
+
+! Assume an array of cells with an initial distribution of live
+! and dead cells, and imaginary cells off the end of the array
+! having fixed values.
+
+! Cells in the next generation of the array are calculated based
+! on the value of the cell and its left and right nearest
+! neighbours in the current generation. If, in the following
+! table, a live cell is represented by 1 and a dead cell by 0 then
+! to generate the value of the cell at a particular index in the
+! array of cellular values you use the following table:
+
+! 000 -> 0 #
+! 001 -> 0 #
+! 010 -> 0 # Dies without enough neighbours
+! 011 -> 1 # Needs one neighbour to survive
+! 100 -> 0 #
+! 101 -> 1 # Two neighbours giving birth
+! 110 -> 1 # Needs one neighbour to survive
+! 111 -> 0 # Starved to death.
+
+: bool-sum ( bool1 bool2 -- sum )
+ [ [ 2 ] [ 1 ] if ]
+ [ [ 1 ] [ 0 ] if ] if ;
+
+:: neighbours ( index world -- # )
+ index [ 1 - ] [ 1 + ] bi [ world ?nth ] bi@ bool-sum ;
+
+: count-neighbours ( world -- neighbours )
+ [ length iota ] keep [ neighbours ] curry map ;
+
+: life-law ( alive? neighbours -- alive? )
+ swap [ 1 = ] [ 2 = ] if ;
+
+: step ( world -- world' )
+ dup count-neighbours [ life-law ] ?{ } 2map-as ;
+
+: print-cellular ( world -- )
+ [ CHAR: # CHAR: _ ? ] "" map-as print ;
+
+: main-cellular ( -- )
+ ?{ f t t t f t t f t f t f t f t f f t f f }
+ 10 [ dup print-cellular step ] times print-cellular ;
+
+MAIN: main-cellular
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.rectangles opengl.gl sequences ui
+ui.gadgets ui.render ;
+IN: rosetta-code.opengl
+
+! http://rosettacode.org/wiki/OpenGL
+
+! In this task, the goal is to display a smooth shaded triangle
+! with OpenGL.
+
+TUPLE: triangle-gadget < gadget ;
+
+: reshape ( width height -- )
+ [ 0 0 ] 2dip glViewport
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ -30.0 30.0 -30.0 30.0 -30.0 30.0 glOrtho
+ GL_MODELVIEW glMatrixMode ;
+
+: paint ( -- )
+ 0.3 0.3 0.3 0.0 glClearColor
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_SMOOTH glShadeModel
+ glLoadIdentity
+ -15.0 -15.0 0.0 glTranslatef
+ GL_TRIANGLES glBegin
+ 1.0 0.0 0.0 glColor3f 0.0 0.0 glVertex2f
+ 0.0 1.0 0.0 glColor3f 30.0 0.0 glVertex2f
+ 0.0 0.0 1.0 glColor3f 0.0 30.0 glVertex2f
+ glEnd
+ glFlush ;
+
+M: triangle-gadget pref-dim* drop { 640 480 } ;
+M: triangle-gadget draw-gadget*
+ rect-bounds nip first2 reshape paint ;
+
+: triangle-window ( -- )
+ [ triangle-gadget new "Triangle" open-window ] with-ui ;
+
+MAIN: triangle-window
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry grouping http.client io io.encodings.utf8 io.files
+io.files.temp kernel math math.order memoize sequences
+unicode.case urls ;
+IN: rosetta-code.ordered-words
+
+! http://rosettacode.org/wiki/Ordered_words
+
+! Define an ordered word as a word in which the letters of the
+! word appear in alphabetic order. Examples include 'abbey' and
+! 'dirt'.
+
+! The task is to find and display all the ordered words in this
+! dictionary that have the longest word length. (Examples that
+! access the dictionary file locally assume that you have
+! downloaded this file yourself.) The display needs to be shown on
+! this page.
+
+MEMO: word-list ( -- seq )
+ "unixdict.txt" temp-file dup exists? [
+ URL" http://puzzlers.org/pub/wordlists/unixdict.txt"
+ over download-to
+ ] unless utf8 file-lines ;
+
+: ordered-word? ( word -- ? )
+ >lower 2 <clumps> [ first2 <= ] all? ;
+
+: filter-longest-words ( seq -- seq' )
+ dup [ length ] [ max ] map-reduce
+ '[ length _ = ] filter ;
+
+: ordered-words-main ( -- )
+ word-list [ ordered-word? ] filter
+ filter-longest-words [ print ] each ;
+
+MAIN: ordered-words-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: grouping kernel math sequences ;
+IN: rosetta-code.pascals-triangle
+
+! http://rosettacode.org/wiki/Pascal%27s_triangle
+
+! Pascal's triangle is an interesting math concept. Its first few rows look like this:
+! 1
+! 1 1
+! 1 2 1
+! 1 3 3 1
+
+! where each element of each row is either 1 or the sum of the
+! two elements right above it. For example, the next row would be
+! 1 (since the first element of each row doesn't have two elements
+! above it), 4 (1 + 3), 6 (3 + 3), 4 (3 + 1), and 1 (since the
+! last element of each row doesn't have two elements above it).
+! Each row n (starting with row 0 at the top) shows the
+! coefficients of the binomial expansion of (x + y)n.
+
+! Write a function that prints out the first n rows of the
+! triangle (with f(1) yielding the row consisting of only the
+! element 1). This can be done either by summing elements from the
+! previous rows or using a binary coefficient or combination
+! function. Behavior for n <= 0 does not need to be uniform, but
+! should be noted.
+
+: (pascal) ( seq -- newseq )
+ dup last 0 prefix 0 suffix 2 <clumps> [ sum ] map suffix ;
+
+: pascal ( n -- seq )
+ 1 - { { 1 } } swap [ (pascal) ] times ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators.random io kernel macros math
+math.statistics prettyprint quotations sequences sorting formatting ;
+IN: rosettacode.probabilistic-choice
+
+! http://rosettacode.org/wiki/Probabilistic_choice
+
+! Given a mapping between items and their required probability
+! of occurrence, generate a million items randomly subject to the
+! given probabilities and compare the target probability of
+! occurrence versus the generated values.
+
+! The total of all the probabilities should equal one. (Because
+! floating point arithmetic is involved this is subject to
+! rounding errors).
+
+! Use the following mapping to test your programs:
+! aleph 1/5.0
+! beth 1/6.0
+! gimel 1/7.0
+! daleth 1/8.0
+! he 1/9.0
+! waw 1/10.0
+! zayin 1/11.0
+! heth 1759/27720 # adjusted so that probabilities add to 1
+
+CONSTANT: data
+{
+ { "aleph" 1/5.0 }
+ { "beth" 1/6.0 }
+ { "gimel" 1/7.0 }
+ { "daleth" 1/8.0 }
+ { "he" 1/9.0 }
+ { "waw" 1/10.0 }
+ { "zayin" 1/11.0 }
+ { "heth" f }
+}
+
+MACRO: case-probas ( data -- case-probas )
+ [ first2 [ swap 1quotation 2array ] [ 1quotation ] if* ] map 1quotation ;
+
+: expected ( name data -- float )
+ 2dup at [ 2nip ] [ nip values sift sum 1 swap - ] if* ;
+
+: generate ( # case-probas -- seq )
+ H{ } clone
+ [ [ [ casep ] [ inc-at ] bi* ] 2curry times ] keep ; inline
+
+: normalize ( seq # -- seq )
+ [ clone ] dip [ /f ] curry assoc-map ;
+
+: summarize1 ( name value data -- )
+ [ over ] dip expected
+ "%6s: %10f %10f\n" printf ;
+
+: summarize ( generated data -- )
+ "Key" "Value" "expected" "%6s %10s %10s\n" printf
+ [ summarize1 ] curry assoc-each ;
+
+: generate-normalized ( # proba -- seq )
+ [ generate ] [ drop normalize ] 2bi ; inline
+
+: example ( # data -- )
+ [ case-probas generate-normalized ]
+ [ summarize ] bi ; inline
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays formatting kernel literals math
+math.functions math.matrices math.ranges sequences ;
+IN: rosetta-code.pythagorean-triples
+
+! http://rosettacode.org/wiki/Pythagorean_triples
+
+! A Pythagorean triple is defined as three positive integers
+! (a,b,c) where a < b < c, and a2 + b2 = c2. They are called
+! primitive triples if a,b,c are coprime, that is, if their
+! pairwise greatest common divisors gcd(a,b) = gcd(a,c) = gcd(b,c)
+! = 1. Because of their relationship through the Pythagorean
+! theorem, a, b, and c are coprime if a and b are coprime
+! (gcd(a,b) = 1). Each triple forms the length of the sides of a
+! right triangle, whose perimeter is P = a + b + c.
+
+! Task
+
+! The task is to determine how many Pythagorean triples there
+! are with a perimeter no larger than 100 and the number of these
+! that are primitive.
+
+! Extra credit: Deal with large values. Can your program handle
+! a max perimeter of 1,000,000? What about 10,000,000?
+! 100,000,000?
+
+! Note: the extra credit is not for you to demonstrate how fast
+! your language is compared to others; you need a proper algorithm
+! to solve them in a timely manner.
+
+CONSTANT: T1 {
+ { 1 2 2 }
+ { -2 -1 -2 }
+ { 2 2 3 }
+}
+CONSTANT: T2 {
+ { 1 2 2 }
+ { 2 1 2 }
+ { 2 2 3 }
+}
+CONSTANT: T3 {
+ { -1 -2 -2 }
+ { 2 1 2 }
+ { 2 2 3 }
+}
+
+CONSTANT: base { 3 4 5 }
+
+TUPLE: triplets-count primitives total ;
+
+: <0-triplets-count> ( -- a ) 0 0 \ triplets-count boa ;
+
+: next-triplet ( triplet T -- triplet' ) [ 1array ] [ m. ] bi* first ;
+
+: candidates-triplets ( seed -- candidates )
+ ${ T1 T2 T3 } [ next-triplet ] with map ;
+
+: add-triplets ( current-triples limit triplet -- stop )
+ sum 2dup > [
+ /i [ + ] curry change-total
+ [ 1 + ] change-primitives drop t
+ ] [ 3drop f ] if ;
+
+: all-triplets ( current-triples limit seed -- triplets )
+ 3dup add-triplets [
+ candidates-triplets [ all-triplets ] with swapd reduce
+ ] [ 2drop ] if ;
+
+: count-triplets ( limit -- count )
+ <0-triplets-count> swap base all-triplets ;
+
+: pprint-triplet-count ( limit count -- )
+ [ total>> ] [ primitives>> ] bi
+ "Up to %d: %d triples, %d primitives.\n" printf ;
+
+: pyth ( -- )
+ 8 [1,b] [ 10^ dup count-triplets pprint-triplet-count ] each ;
+
+
--- /dev/null
+
+USING: tools.test ;
+
+IN: rosetta-code.raycasting
+
+CONSTANT: square { { -2 -1 } { 1 -2 } { 2 1 } { -1 2 } }
+
+{ t } [ square { 0 0 } raycast ] unit-test
+{ f } [ square { 5 5 } raycast ] unit-test
+{ f } [ square { 2 0 } raycast ] unit-test
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel prettyprint sequences arrays math math.vectors ;
+IN: rosetta-code.raycasting
+
+
+! http://rosettacode.org/wiki/Ray-casting_algorithm
+
+! Given a point and a polygon, check if the point is inside or
+! outside the polygon using the ray-casting algorithm.
+
+! A pseudocode can be simply:
+
+! count ← 0
+! foreach side in polygon:
+! if ray_intersects_segment(P,side) then
+! count ← count + 1
+! if is_odd(count) then
+! return inside
+! else
+! return outside
+
+! Where the function ray_intersects_segment return true if the
+! horizontal ray starting from the point P intersects the side
+! (segment), false otherwise.
+
+! An intuitive explanation of why it works is that every time we
+! cross a border, we change "country" (inside-outside, or
+! outside-inside), but the last "country" we land on is surely
+! outside (since the inside of the polygon is finite, while the
+! ray continues towards infinity). So, if we crossed an odd number
+! of borders we was surely inside, otherwise we was outside; we
+! can follow the ray backward to see it better: starting from
+! outside, only an odd number of crossing can give an inside:
+! outside-inside, outside-inside-outside-inside, and so on (the -
+! represents the crossing of a border).
+
+! So the main part of the algorithm is how we determine if a ray
+! intersects a segment. The following text explain one of the
+! possible ways.
+
+! Looking at the image on the right, we can easily be convinced
+! of the fact that rays starting from points in the hatched area
+! (like P1 and P2) surely do not intersect the segment AB. We also
+! can easily see that rays starting from points in the greenish
+! area surely intersect the segment AB (like point P3).
+
+! So the problematic points are those inside the white area (the
+! box delimited by the points A and B), like P4.
+
+! Let us take into account a segment AB (the point A having y
+! coordinate always smaller than B's y coordinate, i.e. point A is
+! always below point B) and a point P. Let us use the cumbersome
+! notation PAX to denote the angle between segment AP and AX,
+! where X is always a point on the horizontal line passing by A
+! with x coordinate bigger than the maximum between the x
+! coordinate of A and the x coordinate of B. As explained
+! graphically by the figures on the right, if PAX is greater than
+! the angle BAX, then the ray starting from P intersects the
+! segment AB. (In the images, the ray starting from PA does not
+! intersect the segment, while the ray starting from PB in the
+! second picture, intersects the segment).
+
+! Points on the boundary or "on" a vertex are someway special
+! and through this approach we do not obtain coherent results.
+! They could be treated apart, but it is not necessary to do so.
+
+! An algorithm for the previous speech could be (if P is a
+! point, Px is its x coordinate):
+
+! ray_intersects_segment:
+! P : the point from which the ray starts
+! A : the end-point of the segment with the smallest y coordinate
+! (A must be "below" B)
+! B : the end-point of the segment with the greatest y coordinate
+! (B must be "above" A)
+! if Py = Ay or Py = By then
+! Py ← Py + ε
+! end if
+! if Py < Ay or Py > By then
+! return false
+! else if Px > max(Ax, Bx) then
+! return false
+! else
+! if Px < min(Ax, Bx) then
+! return true
+! else
+! if Ax ≠ Bx then
+! m_red ← (By - Ay)/(Bx - Ax)
+! else
+! m_red ← ∞
+! end if
+! if Ax ≠ Px then
+! m_blue ← (Py - Ay)/(Px - Ax)
+! else
+! m_blue ← ∞
+! end if
+! if m_blue ≥ m_red then
+! return true
+! else
+! return false
+! end if
+! end if
+! end if
+
+! (To avoid the "ray on vertex" problem, the point is moved
+! upward of a small quantity ε)
+
+: between ( a b x -- ? ) [ last ] tri@ [ < ] curry bi@ xor ;
+
+: lincomb ( a b x -- w )
+ 3dup [ last ] tri@
+ [ - ] curry bi@
+ [ drop ] 2dip
+ neg 2dup + [ / ] curry bi@
+ [ [ v*n ] curry ] bi@ bi* v+ ;
+
+: leftof ( a b x -- ? ) dup [ lincomb ] dip [ first ] bi@ > ;
+
+: ray ( a b x -- ? ) [ between ] [ leftof ] 3bi and ;
+
+: raycast ( poly x -- ? )
+ [ dup first suffix [ rest-slice ] [ but-last-slice ] bi ] dip
+ [ ray ] curry 2map
+ f [ xor ] reduce ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel math sequences ;
+IN: rosetta-code.sierpinski-triangle
+
+! http://rosettacode.org/wiki/Sierpinski_triangle
+
+! Produce an ASCII representation of a Sierpinski triangle of
+! order N. For example, the Sierpinski triangle of order 4 should
+! look like this:
+
+! *
+! * *
+! * *
+! * * * *
+! * *
+! * * * *
+! * * * *
+! * * * * * * * *
+! * *
+! * * * *
+! * * * *
+! * * * * * * * *
+! * * * *
+! * * * * * * * *
+! * * * * * * * *
+! * * * * * * * * * * * * * * * *
+
+: iterate-triangle ( triange spaces -- triangle' )
+ [ [ dup surround ] curry map ]
+ [ drop [ dup " " glue ] map ] 2bi append ;
+
+: (sierpinski) ( triangle spaces n -- triangle' )
+ dup 0 = [ 2drop "\n" join ] [
+ [
+ [ iterate-triangle ]
+ [ nip dup append ] 2bi
+ ] dip 1 - (sierpinski)
+ ] if ;
+
+: sierpinski ( n -- )
+ [ { "*" } " " ] dip (sierpinski) print ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io kernel math math.functions math.parser
+sequences ;
+IN: rosetta-code.standard-deviation
+
+! http://rosettacode.org/wiki/Standard_deviation
+
+! Write a stateful function, class, generator or coroutine that
+! takes a series of floating point numbers, one at a time, and
+! returns the running standard deviation of the series. The task
+! implementation should use the most natural programming style of
+! those listed for the function in the implementation language;
+! the task must state which is being used. Do not apply Bessel's
+! correction; the returned standard deviation should always be
+! computed as if the sample seen so far is the entire population.
+
+! Use this to compute the standard deviation of this
+! demonstration set, {2,4,4,4,5,5,7,9}, which is 2.
+
+TUPLE: standard-deviator sum sum^2 n ;
+
+: <standard-deviator> ( -- standard-deviator )
+ 0.0 0.0 0 standard-deviator boa ;
+
+: current-std ( standard-deviator -- std )
+ [ [ sum^2>> ] [ n>> ] bi / ]
+ [ [ sum>> ] [ n>> ] bi / sq ] bi - sqrt ;
+
+: add-value ( value standard-deviator -- )
+ [ nip [ 1 + ] change-n drop ]
+ [ [ + ] change-sum drop ]
+ [ [ [ sq ] dip + ] change-sum^2 drop ] 2tri ;
+
+: std-main ( -- )
+ { 2 4 4 4 5 5 7 9 }
+ <standard-deviator> [ [ add-value ] curry each ] keep
+ current-std number>string print ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel ;
+IN: rosetta-code.ternary-logic
+
+! http://rosettacode.org/wiki/Ternary_logic
+
+! In logic, a three-valued logic (also trivalent, ternary, or
+! trinary logic, sometimes abbreviated 3VL) is any of several
+! many-valued logic systems in which there are three truth values
+! indicating true, false and some indeterminate third value. This
+! is contrasted with the more commonly known bivalent logics (such
+! as classical sentential or boolean logic) which provide only for
+! true and false. Conceptual form and basic ideas were initially
+! created by Łukasiewicz, Lewis and Sulski. These were then
+! re-formulated by Grigore Moisil in an axiomatic algebraic form,
+! and also extended to n-valued logics in 1945.
+
+! Task:
+
+! * Define a new type that emulates ternary logic by storing data trits.
+
+! * Given all the binary logic operators of the original
+! programming language, reimplement these operators for the new
+! Ternary logic type trit.
+
+! * Generate a sampling of results using trit variables.
+
+! * Kudos for actually thinking up a test case algorithm where
+! ternary logic is intrinsically useful, optimises the test case
+! algorithm and is preferable to binary logic.
+
+SINGLETON: m
+UNION: trit t m POSTPONE: f ;
+
+GENERIC: >trit ( object -- trit )
+M: trit >trit ;
+
+: tnot ( trit1 -- trit )
+ >trit { { t [ f ] } { m [ m ] } { f [ t ] } } case ;
+
+: tand ( trit1 trit2 -- trit )
+ >trit {
+ { t [ >trit ] }
+ { m [ >trit { { t [ m ] } { m [ m ] } { f [ f ] } } case ] }
+ { f [ >trit drop f ] }
+ } case ;
+
+: tor ( trit1 trit2 -- trit )
+ >trit {
+ { t [ >trit drop t ] }
+ { m [ >trit { { t [ t ] } { m [ m ] } { f [ m ] } } case ] }
+ { f [ >trit ] }
+ } case ;
+
+: txor ( trit1 trit2 -- trit )
+ >trit {
+ { t [ tnot ] }
+ { m [ >trit drop m ] }
+ { f [ >trit ] }
+ } case ;
+
+: t= ( trit1 trit2 -- trit )
+ {
+ { t [ >trit ] }
+ { m [ >trit drop m ] }
+ { f [ tnot ] }
+ } case ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors http.client io io.encodings.ascii io.files
+io.files.temp kernel math math.parser memoize sequences
+splitting urls ;
+IN: rosetta-code.text-processing.max-licenses
+
+! http://rosettacode.org/wiki/Text_processing/Max_licenses_in_use
+
+! A company currently pays a fixed sum for the use of a
+! particular licensed software package. In determining if it has a
+! good deal it decides to calculate its maximum use of the
+! software from its license management log file.
+
+! Assume the software's licensing daemon faithfully records a
+! checkout event when a copy of the software starts and a checkin
+! event when the software finishes to its log file. An example of
+! checkout and checkin events are:
+
+! License OUT @ 2008/10/03_23:51:05 for job 4974
+! ...
+! License IN @ 2008/10/04_00:18:22 for job 4974
+
+! Save the 10,000 line log file from here into a local file then
+! write a program to scan the file extracting both the maximum
+! licenses that were out at any time, and the time(s) at which
+! this occurs.
+
+TUPLE: maxlicense max-count current-count times ;
+
+<PRIVATE
+
+: <maxlicense> ( -- max ) -1 0 V{ } clone \ maxlicense boa ; inline
+
+: out? ( line -- ? ) [ "OUT" ] dip subseq? ; inline
+
+: line-time ( line -- time ) " " split harvest fourth ; inline
+
+: update-max-count ( max -- max' )
+ dup [ current-count>> ] [ max-count>> ] bi >
+ [ dup current-count>> >>max-count V{ } clone >>times ] when ;
+
+: (inc-current-count) ( max ? -- max' )
+ [ [ 1 + ] change-current-count ]
+ [ [ 1 - ] change-current-count ]
+ if
+ update-max-count ; inline
+
+: inc-current-count ( max ? time -- max' time )
+ [ (inc-current-count) ] dip ;
+
+: current-max-equal? ( max -- max ? )
+ dup [ current-count>> ] [ max-count>> ] bi = ;
+
+: update-time ( max time -- max' )
+ [ current-max-equal? ] dip
+ swap
+ [ [ suffix ] curry change-times ] [ drop ] if ;
+
+: split-line ( line -- ? time ) [ out? ] [ line-time ] bi ;
+
+: process ( max line -- max ) split-line inc-current-count update-time ;
+
+MEMO: mlijobs ( -- lines )
+ "mlijobs.txt" temp-file dup exists? [
+ URL" http://rosettacode.org/resources/mlijobs.txt"
+ over download-to
+ ] unless ascii file-lines ;
+
+PRIVATE>
+
+: find-max-licenses ( -- max )
+ mlijobs <maxlicense> [ process ] reduce ;
+
+: print-max-licenses ( max -- )
+ [ times>> ] [ max-count>> ] bi
+ "Maximum simultaneous license use is " write
+ number>string write
+ " at the following times: " print
+ [ print ] each ;
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry io kernel math.parser sequences
+sorting ;
+IN: rosetta-code.top-rank
+
+! http://rosettacode.org/wiki/Top_rank_per_group
+
+! Find the top N salaries in each department, where N is
+! provided as a parameter.
+
+! Use this data as a formatted internal data structure (adapt it
+! to your language-native idioms, rather than parse at runtime),
+! or identify your external data source:
+
+! Employee Name,Employee ID,Salary,Department
+! Tyler Bennett,E10297,32000,D101
+! John Rappl,E21437,47000,D050
+! George Woltman,E00127,53500,D101
+! Adam Smith,E63535,18000,D202
+! Claire Buckman,E39876,27800,D202
+! David McClellan,E04242,41500,D101
+! Rich Holcomb,E01234,49500,D202
+! Nathan Adams,E41298,21900,D050
+! Richard Potter,E43128,15900,D101
+! David Motsinger,E27002,19250,D202
+! Tim Sampair,E03033,27000,D101
+! Kim Arlich,E10001,57000,D190
+! Timothy Grove,E16398,29900,D190
+
+TUPLE: employee name id salary department ;
+
+CONSTANT: employees {
+ T{ employee f "Tyler Bennett" "E10297" 32000 "D101" }
+ T{ employee f "John Rappl" "E21437" 47000 "D050" }
+ T{ employee f "George Woltman" "E00127" 53500 "D101" }
+ T{ employee f "Adam Smith" "E63535" 18000 "D202" }
+ T{ employee f "Claire Buckman" "E39876" 27800 "D202" }
+ T{ employee f "David McClellan" "E04242" 41500 "D101" }
+ T{ employee f "Rich Holcomb" "E01234" 49500 "D202" }
+ T{ employee f "Nathan Adams" "E41298" 21900 "D050" }
+ T{ employee f "Richard Potter" "E43128" 15900 "D101" }
+ T{ employee f "David Motsinger" "E27002" 19250 "D202" }
+ T{ employee f "Tim Sampair" "E03033" 27000 "D101" }
+ T{ employee f "Kim Arlich" "E10001" 57000 "D190" }
+ T{ employee f "Timothy Grove" "E16398" 29900 "D190" }
+ }
+
+: group-by ( seq quot -- hash )
+ H{ } clone [ '[ dup @ _ push-at ] each ] keep ; inline
+
+: prepare-departments ( seq -- departments )
+ [ department>> ] group-by
+ [ [ salary>> ] inv-sort-with ] assoc-map ;
+
+: first-n-each ( seq n quot -- )
+ [ short head-slice ] dip each ; inline
+
+: top-rank-main ( -- )
+ employees prepare-departments [
+ [ "Department " write write ":" print ] dip
+ 3 [
+ [ id>> write " $" write ]
+ [ salary>> number>string write " " write ]
+ [ name>> print ] tri
+ ] first-n-each
+ nl
+ ] assoc-each ;
+
+MAIN: top-rank-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: formatting kernel locals math ;
+IN: rosetta-code.towers-of-hanoi
+
+! http://rosettacode.org/wiki/Towers_of_Hanoi
+
+! In this task, the goal is to solve the Towers of Hanoi problem
+! with recursion.
+
+: move ( from to -- )
+ "%d->%d\n" printf ;
+
+:: hanoi ( n from to other -- )
+ n 0 > [
+ n 1 - from other to hanoi
+ from to move
+ n 1 - other to from hanoi
+ ] when ;
+
+! USAGE: 3 1 3 2 hanoi
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators deques dlists fry io kernel
+math.parser ;
+IN: rosetta-code.tree-traversal
+
+! http://rosettacode.org/wiki/Tree_traversal
+
+! Implement a binary tree where each node carries an integer,
+! and implement preoder, inorder, postorder and level-order
+! traversal. Use those traversals to output the following tree:
+
+! 1
+! / \
+! / \
+! / \
+! 2 3
+! / \ /
+! 4 5 6
+! / / \
+! 7 8 9
+
+! The correct output should look like this:
+
+! preorder: 1 2 4 7 5 3 6 8 9
+! inorder: 7 4 2 5 1 8 6 9 3
+! postorder: 7 4 5 2 8 9 6 3 1
+! level-order: 1 2 3 4 5 6 7 8 9
+
+TUPLE: node data left right ;
+
+CONSTANT: example-tree
+ T{ node f 1
+ T{ node f 2
+ T{ node f 4
+ T{ node f 7 f f }
+ f
+ }
+ T{ node f 5 f f }
+ }
+ T{ node f 3
+ T{ node f 6
+ T{ node f 8 f f }
+ T{ node f 9 f f }
+ }
+ f
+ }
+ }
+
+: preorder ( node quot: ( data -- ) -- )
+ [ [ data>> ] dip call ]
+ [ [ left>> ] dip over [ preorder ] [ 2drop ] if ]
+ [ [ right>> ] dip over [ preorder ] [ 2drop ] if ]
+ 2tri ; inline recursive
+
+: inorder ( node quot: ( data -- ) -- )
+ [ [ left>> ] dip over [ inorder ] [ 2drop ] if ]
+ [ [ data>> ] dip call ]
+ [ [ right>> ] dip over [ inorder ] [ 2drop ] if ]
+ 2tri ; inline recursive
+
+: postorder ( node quot: ( data -- ) -- )
+ [ [ left>> ] dip over [ postorder ] [ 2drop ] if ]
+ [ [ right>> ] dip over [ postorder ] [ 2drop ] if ]
+ [ [ data>> ] dip call ]
+ 2tri ; inline recursive
+
+: (levelorder) ( dlist quot: ( data -- ) -- )
+ over deque-empty? [ 2drop ] [
+ [ dup pop-front ] dip {
+ [ [ data>> ] dip call drop ]
+ [ drop left>> [ swap push-back ] [ drop ] if* ]
+ [ drop right>> [ swap push-back ] [ drop ] if* ]
+ [ nip (levelorder) ]
+ } 3cleave
+ ] if ; inline recursive
+
+: levelorder ( node quot: ( data -- ) -- )
+ [ 1dlist ] dip (levelorder) ; inline
+
+: levelorder2 ( node quot: ( data -- ) -- )
+ [ 1dlist ] dip
+ [ dup deque-empty? not ] swap '[
+ dup pop-front
+ [ data>> @ ]
+ [ left>> [ over push-back ] when* ]
+ [ right>> [ over push-back ] when* ] tri
+ ] while drop ; inline
+
+: tree-traversal-main ( -- )
+ example-tree [ number>string write " " write ] {
+ [ "preorder: " write preorder nl ]
+ [ "inorder: " write inorder nl ]
+ [ "postorder: " write postorder nl ]
+ [ "levelorder: " write levelorder nl ]
+ [ "levelorder2: " write levelorder2 nl ]
+ } 2cleave ;
+
+MAIN: tree-traversal-main
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.client io kernel math sequences ;
+IN: rosetta-code.web-scraping
+
+! http://rosettacode.org/wiki/Web_scraping
+
+! Create a program that downloads the time from this URL:
+! http://tycho.usno.navy.mil/cgi-bin/timer.pl and then prints the
+! current UTC time by extracting just the UTC time from the web
+! page's HTML.
+
+! If possible, only use libraries that come at no extra monetary
+! cost with the programming language and that are widely available
+! and popular such as CPAN for Perl or Boost for C++.
+
+: web-scraping-main ( -- )
+ "http://tycho.usno.navy.mil/cgi-bin/timer.pl" http-get nip
+ [ "UTC" swap start [ 9 - ] [ 1 - ] bi ] keep subseq print ;
+
+MAIN: web-scraping-main
--- /dev/null
+USING: kernel tools.test ;
+IN: rosettacode.y-combinator
+
+[ 120 ] [ 5 [ almost-fac ] Y call ] unit-test
+[ 8 ] [ 6 [ almost-fib ] Y call ] unit-test
+
--- /dev/null
+! Copyright (c) 2012 Anonymous
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry kernel math ;
+IN: rosettacode.y-combinator
+
+! http://rosettacode.org/wiki/Y_combinator
+
+! In strict functional programming and the lambda calculus,
+! functions (lambda expressions) don't have state and are only
+! allowed to refer to arguments of enclosing functions. This rules
+! out the usual definition of a recursive function wherein a
+! function is associated with the state of a variable and this
+! variable's state is used in the body of the function.
+
+! The Y combinator is itself a stateless function that, when
+! applied to another stateless function, returns a recursive
+! version of the function. The Y combinator is the simplest of the
+! class of such functions, called fixed-point combinators.
+
+! The task is to define the stateless Y combinator and use it to
+! compute factorials and Fibonacci numbers from other stateless
+! functions or lambda expressions.
+
+: Y ( quot -- quot )
+ '[ [ dup call call ] curry _ call ] dup call( x -- x ) ;
+
+: almost-fac ( quot -- quot )
+ '[ dup zero? [ drop 1 ] [ dup 1 - _ call * ] if ] ;
+
+: almost-fib ( quot -- quot )
+ '[ dup 2 >= [ 1 2 [ - _ call ] bi-curry@ bi + ] when ] ;
projects / factor.git / commitdiff