diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 6c1930b463..02c4da0d12 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -117,6 +117,10 @@ HELP: log { $values { "x" number } { "y" number } } { $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; +HELP: logn +{ $values { "x" number } { "n" number } { "y" number } } +{ $description "Finds the base " { $snippet "n" } " logarithm of " { $snippet "x" } "." } ; + HELP: log1+ { $values { "x" number } { "y" number } } { $description "Takes the natural logarithm of " { $snippet "1 + x" } ". Outputs negative infinity if " { $snippet "1 + x" } " is zero. This word may be more accurate than " { $snippet "1 + log" } " for very small values of " { $snippet "x" } "." } ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index ac30a9e5be..d543a4ba8d 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -69,6 +69,10 @@ IN: math.functions.tests { 0.0 } [ 1.0 log ] unit-test { 1.0 } [ e log ] unit-test +{ 0.0 } [ 1 e logn ] unit-test +{ 0.0 } [ 1.0 e logn ] unit-test +{ 1.0 } [ e e logn ] unit-test + CONSTANT: log-factorial-1000 0x1.71820d04e2eb6p12 CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11 diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 33fc2e55d3..f18923885e 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -196,6 +196,8 @@ M: real log >float log ; inline M: complex log >polar [ flog ] dip rect> ; inline +: logn ( x n -- y ) [ log ] bi@ / ; + > dim>> ] [ orientation>> ] bi v. - elevator-padding 2 * - ; + elevator-padding 2 * [-] ; CONSTANT: min-thumb-dim 30 diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor deleted file mode 100644 index 12b58513f9..0000000000 --- a/extra/flatland/flatland.factor +++ /dev/null @@ -1,227 +0,0 @@ - -USING: accessors arrays combinators combinators.short-circuit -fry kernel locals math math.intervals math.vectors multi-methods -sequences ; -IN: flatland - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Two dimensional world protocol - -MULTI-GENERIC: x ( obj -- x ) -MULTI-GENERIC: y ( obj -- y ) - -MULTI-GENERIC: (x!) ( x obj -- ) -MULTI-GENERIC: (y!) ( y obj -- ) - -: x! ( obj x -- obj ) over (x!) ; -: y! ( obj y -- obj ) over (y!) ; - -MULTI-GENERIC: width ( obj -- width ) -MULTI-GENERIC: height ( obj -- height ) - -MULTI-GENERIC: (width!) ( width obj -- ) -MULTI-GENERIC: (height!) ( height obj -- ) - -: width! ( obj width -- obj ) over (width!) ; -: height! ( obj height -- obj ) over (width!) ; - -! Predicates on relative placement - -MULTI-GENERIC: to-the-left-of? ( obj obj -- ? ) -MULTI-GENERIC: to-the-right-of? ( obj obj -- ? ) - -MULTI-GENERIC: below? ( obj obj -- ? ) -MULTI-GENERIC: above? ( obj obj -- ? ) - -MULTI-GENERIC: in-between-horizontally? ( obj obj -- ? ) - -MULTI-GENERIC: horizontal-interval ( obj -- interval ) - -MULTI-GENERIC: move-to ( obj obj -- ) - -MULTI-GENERIC: move-by ( obj delta -- ) - -MULTI-GENERIC: move-left-by ( obj obj -- ) -MULTI-GENERIC: move-right-by ( obj obj -- ) - -MULTI-GENERIC: left ( obj -- left ) -MULTI-GENERIC: right ( obj -- right ) -MULTI-GENERIC: bottom ( obj -- bottom ) -MULTI-GENERIC: top ( obj -- top ) - -MULTI-GENERIC: distance ( a b -- c ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Some of the above methods work on two element sequences. -! A two element sequence may represent a point in space or describe -! width and height. - -METHOD: x { sequence } first ; -METHOD: y { sequence } second ; - -METHOD: (x!) { number sequence } set-first ; -METHOD: (y!) { number sequence } set-second ; - -METHOD: width { sequence } first ; -METHOD: height { sequence } second ; - -: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline -: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline - -METHOD: move-to { sequence sequence } [ x x! ] [ y y! ] bi drop ; -METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ; - -METHOD: move-left-by { sequence number } '[ _ - ] changed-x ; -METHOD: move-right-by { sequence number } '[ _ + ] changed-x ; - -! METHOD: move-left-by { sequence number } neg 0 2array move-by ; -! METHOD: move-right-by { sequence number } 0 2array move-by ; - -! METHOD:: move-left-by { SEQ:sequence X:number -- ) -! SEQ { X 0 } { -1 0 } v* move-by ; - -METHOD: distance { sequence sequence } v- norm ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! A class for objects with a position - -TUPLE: pos pos ; - -METHOD: x { pos } pos>> first ; -METHOD: y { pos } pos>> second ; - -METHOD: (x!) { number pos } pos>> set-first ; -METHOD: (y!) { number pos } pos>> set-second ; - -METHOD: to-the-left-of? { pos number } [ x ] dip < ; -METHOD: to-the-right-of? { pos number } [ x ] dip > ; - -METHOD: move-left-by { pos number } [ pos>> ] dip move-left-by ; -METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ; - -METHOD: above? { pos number } [ y ] dip > ; -METHOD: below? { pos number } [ y ] dip < ; - -METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ; - -METHOD: distance { pos pos } [ pos>> ] bi@ distance ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! A class for objects with velocity. It inherits from pos. Hey, if -! it's moving it has a position right? Unless it's some alternate universe... - -TUPLE: vel < pos vel ; - -: moving-up? ( obj -- ? ) vel>> y 0 > ; -: moving-down? ( obj -- ? ) vel>> y 0 < ; - -: step-size ( vel time -- dist ) [ vel>> ] dip v*n ; -: move-for ( vel time -- ) dupd step-size move-by ; - -: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! The 'pos' slot indicates the lower left hand corner of the -! rectangle. The 'dim' is holds the width and height. - -TUPLE: rectangle < pos dim ; - -METHOD: width { rectangle } dim>> first ; -METHOD: height { rectangle } dim>> second ; - -METHOD: left { rectangle } x ; -METHOD: right { rectangle } [ x ] [ width ] bi + ; -METHOD: bottom { rectangle } y ; -METHOD: top { rectangle } [ y ] [ height ] bi + ; - -: bottom-left ( rectangle -- pos ) pos>> ; - -: center-x ( rectangle -- x ) [ left ] [ width 2 / ] bi + ; -: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ; - -: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ; - -METHOD: to-the-left-of? { pos rectangle } [ x ] [ left ] bi* < ; -METHOD: to-the-right-of? { pos rectangle } [ x ] [ right ] bi* > ; - -METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ; -METHOD: above? { pos rectangle } [ y ] [ top ] bi* > ; - -METHOD: horizontal-interval { rectangle } - [ left ] [ right ] bi [a,b] ; - -METHOD: in-between-horizontally? { pos rectangle } - [ x ] [ horizontal-interval ] bi* interval-contains? ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: extent left right bottom top ; - -METHOD: left { extent } left>> ; -METHOD: right { extent } right>> ; -METHOD: bottom { extent } bottom>> ; -METHOD: top { extent } top>> ; - -METHOD: width { extent } [ right>> ] [ left>> ] bi - ; -METHOD: height { extent } [ top>> ] [ bottom>> ] bi - ; - -! METHOD: to-extent ( rectangle -- extent ) -! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: to-the-left-of? { sequence rectangle } [ x ] [ left ] bi* < ; -METHOD: to-the-right-of? { sequence rectangle } [ x ] [ right ] bi* > ; - -METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ; -METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Some support for the' 'rect' class from math.geometry.rect' - -! METHOD: width ( rect -- width ) dim>> first ; -! METHOD: height ( rect -- height ) dim>> second ; - -! METHOD: left ( rect -- left ) loc>> x -! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ; - -! METHOD: to-the-left-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ; -! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -:: wrap ( POINT RECT -- POINT ) - { - { [ POINT RECT to-the-left-of? ] [ RECT right ] } - { [ POINT RECT to-the-right-of? ] [ RECT left ] } - { [ t ] [ POINT x ] } - } - cond - - { - { [ POINT RECT below? ] [ RECT top ] } - { [ POINT RECT above? ] [ RECT bottom ] } - { [ t ] [ POINT y ] } - } - cond - - 2array ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -MULTI-GENERIC: within? ( a b -- ? ) - -METHOD: within? { pos rectangle } - { - [ left to-the-right-of? ] - [ right to-the-left-of? ] - [ bottom above? ] - [ top below? ] - } - 2&& ; diff --git a/extra/minesweeper/tags.txt b/extra/minesweeper/tags.txt index cb5fc203e1..1eefa30584 100644 --- a/extra/minesweeper/tags.txt +++ b/extra/minesweeper/tags.txt @@ -1 +1,2 @@ demos +games diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor index fcab4b7cca..ad59df9600 100644 --- a/extra/pong/pong.factor +++ b/extra/pong/pong.factor @@ -1,135 +1,166 @@ -USING: accessors alien.c-types alien.data arrays calendar colors -combinators combinators.short-circuit flatland generalizations -grouping kernel locals math math.intervals math.order -math.rectangles math.vectors namespaces opengl opengl.gl -opengl.glu processing.shapes sequences sequences.generalizations -shuffle threads ui ui.gadgets ui.gestures ui.render ; +USING: accessors arrays calendar colors.constants +combinators.short-circuit fonts fry kernel literals locals math +math.order math.ranges math.vectors namespaces opengl random +sequences timers ui ui.commands ui.gadgets ui.gadgets.worlds +ui.gestures ui.pens.solid ui.render ui.text ; + IN: pong -! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431 -! -! Which was based on this Nodebox version: http://billmill.org/pong.html -! by Bill Mill. +CONSTANT: BOUNCE 6/5 +CONSTANT: MAX-SPEED 6 +CONSTANT: BALL-SIZE 10 +CONSTANT: BALL-DIM ${ BALL-SIZE BALL-SIZE } +CONSTANT: PADDLE-SIZE 80 +CONSTANT: PADDLE-DIM ${ PADDLE-SIZE 10 } +CONSTANT: FONT $[ + monospace-font + t >>bold? + COLOR: red >>foreground + COLOR: gray95 >>background + ] -: clamp-to-interval ( x interval -- x ) - [ from>> first ] [ to>> first ] bi clamp ; +TUPLE: ball pos vel ; -TUPLE: play-field < rectangle ; +TUPLE: pong-gadget < gadget timer ball player computer game-over? ; -TUPLE: paddle < rectangle ; +: initial-state ( gadget -- gadget ) + T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball + 200 >>player + 200 >>computer + f >>game-over? ; -TUPLE: computer < paddle { speed initial: 10 } ; +DEFER: on-tick -: computer-move-left ( computer -- ) dup speed>> move-left-by ; +: ( -- gadget ) + pong-gadget new initial-state + COLOR: gray95 >>interior + dup '[ _ on-tick ] f 16 milliseconds >>timer ; -: computer-move-right ( computer -- ) dup speed>> move-right-by ; +M: pong-gadget pref-dim* drop { 400 400 } ; -TUPLE: ball < vel - { diameter initial: 20 } - { bounciness initial: 1.2 } - { max-speed initial: 10 } ; - -: above-lower-bound? ( ball field -- ? ) bottom 50 - above? ; - -: below-upper-bound? ( ball field -- ? ) top 50 + below? ; - -: in-bounds? ( ball field -- ? ) - { - [ above-lower-bound? ] - [ below-upper-bound? ] - } 2&& ; - -:: bounce-change-vertical-velocity ( BALL -- ) - BALL vel>> y neg - BALL bounciness>> * - BALL max-speed>> min - BALL vel>> (y!) ; - -:: bounce-off-paddle ( BALL PADDLE -- ) - BALL bounce-change-vertical-velocity - BALL x PADDLE center x - 0.25 * BALL vel>> (x!) - PADDLE top BALL pos>> (y!) ; - -: mouse-x ( -- x ) hand-loc get first ; - -:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval ) - PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ; - -:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- ) - mouse-x - PADDLE PLAY-FIELD valid-paddle-interval - clamp-to-interval - PADDLE pos>> (x!) ; - -! Protocol for drawing PONG objects - -GENERIC: draw ( obj -- ) - -M: paddle draw [ bottom-left ] [ dim>> ] bi draw-rectangle ; - -M: ball draw [ pos>> ] [ diameter>> 2 / ] bi draw-circle ; - -TUPLE: pong-gadget < gadget paused field ball player computer ; - -: pong ( -- gadget ) - pong-gadget new - T{ play-field { pos { 0 0 } } { dim { 400 400 } } } clone >>field - T{ ball { pos { 50 50 } } { vel { 3 4 } } } clone >>ball - T{ paddle { pos { 200 396 } } { dim { 75 4 } } } clone >>player - T{ computer { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ; - -M: pong-gadget pref-dim* ( -- dim ) drop { 400 400 } ; - -M: pong-gadget ungraft* ( -- ) t >>paused drop ; +M: pong-gadget ungraft* + [ timer>> stop-timer ] [ call-next-method ] bi ; M:: pong-gadget draw-gadget* ( PONG -- ) - PONG computer>> draw - PONG player>> draw - PONG ball>> draw ; + COLOR: gray80 gl-color + 15 390 20 [ + 197 2array { 10 6 } gl-fill-rect + ] each + + COLOR: black gl-color + { 0 0 } { 10 400 } gl-fill-rect + { 390 0 } { 10 400 } gl-fill-rect + + PONG computer>> 0 2array PADDLE-DIM gl-fill-rect + PONG player>> 390 2array PADDLE-DIM gl-fill-rect + PONG ball>> pos>> BALL-DIM gl-fill-rect + + PONG game-over?>> [ + FONT 48 >>size + PONG ball>> pos>> second 200 < + "YOU WIN!" "YOU LOSE!" ? + [ text-width 390 swap - 2 / 100 2array ] + [ '[ _ _ draw-text ] with-translation ] 2bi + ] [ + PONG timer>> thread>> [ + FONT 24 >>size + { " N - New Game" "SPACE - Pause" } + [ text-width 390 swap - 2 / 100 2array ] + [ '[ _ _ draw-text ] with-translation ] 2bi + ] unless + ] if ; + +:: move-player ( GADGET -- ) + hand-loc get first PADDLE-SIZE 2 / - + 10 390 PADDLE-SIZE - clamp GADGET player<< ; + +:: move-ball ( GADGET -- ) + GADGET ball>> :> BALL + + ! minimum movement to hit wall or paddle + BALL vel>> first dup 0 > 380 10 ? + BALL pos>> first - swap / 1 min + BALL vel>> second dup 0 > 380 10 ? + BALL pos>> second - swap / 1 min min :> movement + + movement 0 > [ movement throw ] unless + BALL pos>> BALL vel>> movement v*n v+ BALL pos<< ; + +: move-computer-by ( GADGET N -- ) + '[ _ + 10 390 PADDLE-SIZE - clamp ] change-computer drop ; + +:: move-computer ( GADGET -- ) + GADGET ball>> pos>> first :> X + GADGET computer>> PADDLE-SIZE 2/ + :> COMPUTER + + ! ball on the left + X BALL-SIZE + COMPUTER - dup 0 < [ + >integer -10 max 0 [a,b] random + GADGET swap move-computer-by + ] [ drop ] if + + ! ball on the right + X COMPUTER - dup 0 > [ + >integer 10 min [0,b] random + GADGET swap move-computer-by + ] [ drop ] if ; + +:: bounce-off-paddle ( BALL PADDLE -- ) + BALL pos>> first BALL-SIZE 2 / + + PADDLE PADDLE-SIZE 2 / + - 1/4 * + BALL vel>> second neg BOUNCE * MAX-SPEED min 2array + BALL vel<< ; + +:: ?bounce-off-paddle ( BALL GADGET PADDLE -- ) + BALL pos>> first dup BALL-SIZE + + PADDLE dup PADDLE-SIZE + '[ _ _ between? ] either? [ + BALL PADDLE bounce-off-paddle + ] [ + GADGET t >>game-over? timer>> stop-timer + ] if ; + +: bounce-off-wall ( BALL -- ) + 0 swap vel>> [ neg ] change-nth ; + +:: on-tick ( GADGET -- ) + GADGET move-player + GADGET move-ball + GADGET move-computer -:: iterate-system ( GADGET -- ) - GADGET field>> :> FIELD GADGET ball>> :> BALL GADGET player>> :> PLAYER GADGET computer>> :> COMPUTER - BALL FIELD in-bounds? [ + BALL pos>> first2 :> ( X Y ) + BALL vel>> first2 :> ( DX DY ) - PLAYER FIELD align-paddle-with-mouse + { [ DY 0 > ] [ Y 380 >= ] } 0&& + [ BALL GADGET PLAYER ?bounce-off-paddle ] when - BALL 1 move-for + { [ DY 0 < ] [ Y 10 <= ] } 0&& + [ BALL GADGET COMPUTER ?bounce-off-paddle ] when - ! computer reaction + X { [ 10 <= ] [ 380 >= ] } 1|| + [ BALL bounce-off-wall ] when - BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when - BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when + GADGET relayout-1 ; - ! check if ball bounced off something +: com-new-game ( gadget -- ) + initial-state timer>> start-timer ; - ! player-blocked-ball? - BALL PLAYER { [ above? ] [ in-between-horizontally? ] } 2&& - [ BALL PLAYER bounce-off-paddle ] when +: com-pause ( gadget -- ) + dup game-over?>> [ + dup timer>> dup thread>> + [ stop-timer ] [ restart-timer ] if + ] unless relayout-1 ; - ! computer-blocked-ball? - BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } 2&& - [ BALL COMPUTER bounce-off-paddle ] when +pong-gadget "gestures" f { + { T{ key-down { sym "n" } } com-new-game } + { T{ key-down { sym " " } } com-pause } +} define-command-map - ! bounced-off-wall? - BALL FIELD in-between-horizontally? not - [ BALL reverse-horizontal-velocity ] when - - ] [ t GADGET paused<< ] if ; - -:: start-pong-thread ( GADGET -- ) - f GADGET paused<< [ - [ - GADGET paused>> - [ f ] - [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ] - if - ] loop - ] in-thread ; - -MAIN-WINDOW: pong-window - { { title "PONG" } } - pong [ >>gadgets ] [ start-pong-thread ] bi ; +MAIN-WINDOW: pong-window { + { title "PONG" } + { window-controls + { normal-title-bar close-button minimize-button } } + } >>gadgets ; diff --git a/extra/pong/tags.txt b/extra/pong/tags.txt index 84d4140a70..1eefa30584 100644 --- a/extra/pong/tags.txt +++ b/extra/pong/tags.txt @@ -1 +1,2 @@ +demos games diff --git a/vm/master.hpp b/vm/master.hpp index 8a3bcf4367..4c87f74b97 100644 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -53,7 +53,7 @@ #endif // Record compilation time -#define FACTOR_COMPILE_TIME __TIMESTAMP__ +#define FACTOR_COMPILE_TIME __DATE__ " " __TIME__ // Detect target CPU type #if defined(__arm__)