rosetta-code: adding implementations of rosettacode.org solutions.
John Benediktsson
parent
49448f0257
commit
bd957cb3b4
|
|
@ -0,0 +1,43 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
! 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) ;
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
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 ;
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
! 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 = ;
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
|
||||
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
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
! 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) ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: tools.test ;
|
||||
IN: rosetta-code.equilibrium-index
|
||||
|
||||
{ V{ 3 6 } } [ { -7 1 5 2 -4 3 0 } equilibrium-indices ] unit-test
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
USING: tools.test ;
|
||||
IN: rosetta-code.happy-numbers
|
||||
|
||||
{ { 1 7 10 13 19 23 28 31 } } [ 8 happy-numbers ] unit-test
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! 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 * ;
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! 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 . ;
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
! 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 = ;
|
||||
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! 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* ;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
! 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 ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
|
||||
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
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: kernel tools.test ;
|
||||
IN: rosettacode.y-combinator
|
||||
|
||||
[ 120 ] [ 5 [ almost-fac ] Y call ] unit-test
|
||||
[ 8 ] [ 6 [ almost-fib ] Y call ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! 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 ] ;
|
||||
Loading…
Reference in New Issue