! http://www.complexification.net/gallery/machines/peterdejong/
IN: dejong
-
-USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-video
-USE: namespaces
-USE: math
-USE: kernel
-USE: test
-USE: compiler
+USING: compiler kernel math namespaces sdl styles test ;
SYMBOL: a
SYMBOL: b
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: dump
-USING: alien assembler generic kernel kernel-internals lists
-math memory sequences io strings unparser ;
-
-: cell. >hex cell 2 * CHAR: 0 pad write ;
-
-: slot@ ( address n -- n ) cell * swap 7 bitnot bitand + ;
-
-: dump-line ( address n value -- )
- >r slot@ cell. ": " write r> cell. terpri ;
-
-: (dump) ( address list -- )
- 0 swap [ >r 2dup r> dump-line 1 + ] each 2drop ;
-
-: integer-slots ( obj -- list )
- dup size cell / [ integer-slot ] project-with ;
-
-: dump ( obj -- )
- #! Dump an object's memory.
- dup address swap integer-slots (dump) ;
-
-: alien-slots ( address length -- list )
- cell / [ cell * alien-unsigned-4 ] project-with ;
-
-: dump* ( alien len -- )
- #! Dump an alien's memory.
- dup string? [ c-size ] when
- >r [ alien-address ] keep r> alien-slots (dump) ;
+++ /dev/null
-IN: format
-USING: kernel math sequences strings test ;
-
-: decimal-split ( string -- string string )
- #! Split a string before and after the decimal point.
- dup "." index-of dup -1 = [ drop f ] [ string// ] ifte ;
-
-: decimal-tail ( count str -- string )
- #! Given a decimal, trims all but a count of decimal places.
- [ length min ] keep string-head ;
-
-: decimal-cat ( before after -- string )
- #! If after is of zero length, return before, otherwise
- #! return "before.after".
- dup length 0 = [
- drop
- ] [
- "." swap cat3
- ] ifte ;
-
-: decimal-places ( num count -- string )
- #! Trims the number to a count of decimal places.
- >r decimal-split dup [
- r> swap decimal-tail decimal-cat
- ] [
- r> 2drop
- ] ifte ;
-
-[ "123" ] [ 4 "123" decimal-tail ] unit-test
-[ "12" ] [ 2 "123" decimal-tail ] unit-test
-[ "123" ] [ "123" 2 decimal-places ] unit-test
-[ "123.12" ] [ "123.12" 2 decimal-places ] unit-test
-[ "123.123" ] [ "123.123" 5 decimal-places ] unit-test
-[ "123" ] [ "123.123" 0 decimal-places ] unit-test
-
-USING: sequences kernel math io strings ;
+USING: sequences kernel math io ;
: lcd-digit ( digit row -- str )
{
" _ _ _ _ _ _ _ _ "
" | | | _| _| |_| |_ |_ | |_| |_| "
" |_| | |_ _| | _| |_| | |_| | "
- } nth >r 4 * dup 4 + r> substring ;
+ } nth >r 4 * dup 4 + r> subseq ;
: lcd-row ( num row -- )
- swap [ CHAR: 0 - over lcd-digit write ] each drop ;
+ swap [ CHAR: 0 - swap lcd-digit write ] each-with ;
-: lcd ( num -- str )
+: lcd ( digit-str -- )
3 [ 2dup lcd-row terpri ] repeat drop ;
+++ /dev/null
-IN: random
-USING: kernel lists math namespaces sequences test ;
-
-: random-element ( list -- random )
- #! Returns a random element from the given list.
- [ length 1 - 0 swap random-int ] keep nth ;
-
-: random-boolean ( -- ? ) 0 1 random-int 0 = ;
-
-: random-subset ( list -- list )
- #! Returns a random subset of the given list. Each item is
- #! chosen with a 50%
- #! probability.
- [ drop random-boolean ] subset ;
-
-: car+ ( list -- sum )
- #! Adds the car of each element of the given list.
- 0 swap [ car + ] each ;
-
-: random-probability ( list -- sum )
- #! Adds the car of each element of the given list, and
- #! returns a random number between 1 and this sum.
- 1 swap car+ random-int ;
-
-: random-element-iter ( list index -- elem )
- #! Used by random-element*. Do not call directly.
- >r unswons unswons r> ( list elem probability index )
- swap - ( list elem index )
- dup 0 <= [
- drop nip
- ] [
- nip random-element-iter
- ] ifte ;
-
-: random-element* ( list -- elem )
- #! Returns a random element of the given list of comma
- #! pairs. The car of each pair is a probability, the cdr is
- #! the item itself. Only the cdr of the comma pair is
- #! returned.
- dup 1 swap car+ random-int random-element-iter ;
-
-: random-subset* ( list -- list )
- #! Returns a random subset of the given list of comma pairs.
- #! The car of each pair is a probability, the cdr is the
- #! item itself. Only the cdr of the comma pair is returned.
- [
- [ car+ ] keep ( probabilitySum list )
- [
- >r 1 over random-int r> ( probabilitySum probability elem )
- uncons ( probabilitySum probability elema elemd )
- -rot ( probabilitySum elemd probability elema )
- > ( probabilitySum elemd boolean )
- [ drop ] [ , ] ifte
- ] each drop
- ] make-list ;
-
-: check-random-subset ( expected pairs -- )
- random-subset* [ over contains? ] all? nip ;
-
-[
- [ t ]
- [ [ 1 2 3 ] random-element number? ]
- unit-test
-
- [
- [[ 10 t ]]
- [[ 20 f ]]
- [[ 30 "monkey" ]]
- [[ 24 1/2 ]]
- [[ 13 { "Hello" "Banana" } ]]
- ] "random-pairs" set
-
- "random-pairs" get [ cdr ] map "random-values" set
-
- [ f ]
- [
- "random-pairs" get
- random-element* "random-values" get contains? not
- ] unit-test
-
- [ t ] [
- "random-values" get
- "random-pairs" get
- check-random-subset
- ] unit-test
-] with-scope
-! Numbers game example
-
IN: numbers-game
USING: kernel math parser random io ;
-: read-number ( -- n ) read parse-number ;
+: read-number ( -- n ) readln parse-number ;
: guess-banner
"I'm thinking of a number between 0 and 100." print ;
< [ too-high ] [ too-low ] ifte ;
: judge-guess ( actual guess -- ? )
- 2dup = [
- 2drop correct f
- ] [
- inexact-guess t
- ] ifte ;
+ 2dup = [ 2drop correct f ] [ inexact-guess t ] ifte ;
: number-to-guess ( -- n ) 0 100 random-int ;
: numbers-game-loop ( actual -- )
- dup guess-prompt read-number judge-guess [
- numbers-game-loop
- ] [
- drop
- ] ifte ;
+ dup guess-prompt read-number judge-guess
+ [ numbers-game-loop ] [ drop ] ifte ;
: numbers-game number-to-guess numbers-game-loop ;
make-plot
<event> event-loop SDL_Quit
] with-screen ;
+
+plot3d
+++ /dev/null
-! :folding=indent:collapseFolds=0:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: quadratic
-USE: math
-USE: kernel
-
-: quadratic-e ( b a -- -b/2a )
- 2 * / neg ;
-
-: quadratic-d ( a b c -- d )
- pick 4 * * swap sq swap - swap sq 4 * / sqrt ;
-
-: quadratic-roots ( d e -- alpha beta )
- 2dup + -rot - ;
-
-: quadratic ( a b c -- alpha beta )
- #! Finds both roots of the polynomial a*x^2 + b*x + c
- #! using the quadratic formula.
- 3dup quadratic-d
- nip swap rot quadratic-e
- swap quadratic-roots ;
+++ /dev/null
-! Contractor timesheet example
-
-IN: timesheet
-USING: errors kernel lists math namespaces sequences io
-strings unparser vectors ;
-
-! Adding a new entry to the time sheet.
-
-: measure-duration ( -- duration )
- millis
- read drop
- millis swap - 1000 /i 60 /i ;
-
-: add-entry-prompt ( -- duration description )
- "Start work on the task now. Press ENTER when done." print
- measure-duration
- "Please enter a description:" print
- read ;
-
-: add-entry ( timesheet -- )
- add-entry-prompt cons swap push ;
-
-! Printing the timesheet.
-
-: hh ( duration -- str ) 60 /i ;
-: mm ( duration -- str ) 60 mod unparse 2 "0" pad ;
-: hh:mm ( millis -- str ) [ dup hh , ":" , mm , ] make-string ;
-
-: pad-string ( len str -- str )
- length - " " fill ;
-
-: print-entry ( duration description -- )
- dup write
- 60 swap pad-string write
- hh:mm print ;
-
-: print-timesheet ( timesheet -- )
- "TIMESHEET:" print
- [ uncons print-entry ] each ;
-
-! Displaying a menu
-
-: print-menu ( menu -- )
- terpri [ cdr car print ] each terpri
- "Enter a letter between ( ) to execute that action." print ;
-
-: menu-prompt ( menu -- )
- read swap assoc dup [
- cdr call
- ] [
- "Invalid input: " swap unparse cat2 throw
- ] ifte ;
-
-: menu ( menu -- )
- dup print-menu menu-prompt ;
-
-! Main menu
-
-: main-menu ( timesheet -- )
- [
- [ "e" "(E)xit" drop ]
- [ "a" "(A)dd entry" dup add-entry main-menu ]
- [ "p" "(P)rint timesheet" dup print-timesheet main-menu ]
- ] menu ;
-
-: timesheet-app ( -- )
- 10 <vector> main-menu ;
projects / factor.git / commitdiff