updated examples
Slava Pestov
parent
f2f1c6705b
commit
06fd239a6f
|
|
@ -17,16 +17,7 @@
|
||||||
! http://www.complexification.net/gallery/machines/peterdejong/
|
! http://www.complexification.net/gallery/machines/peterdejong/
|
||||||
|
|
||||||
IN: dejong
|
IN: dejong
|
||||||
|
USING: compiler kernel math namespaces sdl styles test ;
|
||||||
USE: sdl
|
|
||||||
USE: sdl-event
|
|
||||||
USE: sdl-gfx
|
|
||||||
USE: sdl-video
|
|
||||||
USE: namespaces
|
|
||||||
USE: math
|
|
||||||
USE: kernel
|
|
||||||
USE: test
|
|
||||||
USE: compiler
|
|
||||||
|
|
||||||
SYMBOL: a
|
SYMBOL: a
|
||||||
SYMBOL: b
|
SYMBOL: b
|
||||||
|
|
|
||||||
|
|
@ -1,30 +0,0 @@
|
||||||
! 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) ;
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
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
|
|
||||||
|
|
||||||
|
|
@ -1,14 +1,14 @@
|
||||||
USING: sequences kernel math io strings ;
|
USING: sequences kernel math io ;
|
||||||
|
|
||||||
: lcd-digit ( digit row -- str )
|
: lcd-digit ( digit row -- str )
|
||||||
{
|
{
|
||||||
" _ _ _ _ _ _ _ _ "
|
" _ _ _ _ _ _ _ _ "
|
||||||
" | | | _| _| |_| |_ |_ | |_| |_| "
|
" | | | _| _| |_| |_ |_ | |_| |_| "
|
||||||
" |_| | |_ _| | _| |_| | |_| | "
|
" |_| | |_ _| | _| |_| | |_| | "
|
||||||
} nth >r 4 * dup 4 + r> substring ;
|
} nth >r 4 * dup 4 + r> subseq ;
|
||||||
|
|
||||||
: lcd-row ( num row -- )
|
: 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 ;
|
3 [ 2dup lcd-row terpri ] repeat drop ;
|
||||||
|
|
|
||||||
|
|
@ -1,86 +0,0 @@
|
||||||
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
|
|
||||||
|
|
@ -1,9 +1,7 @@
|
||||||
! Numbers game example
|
|
||||||
|
|
||||||
IN: numbers-game
|
IN: numbers-game
|
||||||
USING: kernel math parser random io ;
|
USING: kernel math parser random io ;
|
||||||
|
|
||||||
: read-number ( -- n ) read parse-number ;
|
: read-number ( -- n ) readln parse-number ;
|
||||||
|
|
||||||
: guess-banner
|
: guess-banner
|
||||||
"I'm thinking of a number between 0 and 100." print ;
|
"I'm thinking of a number between 0 and 100." print ;
|
||||||
|
|
@ -16,19 +14,12 @@ USING: kernel math parser random io ;
|
||||||
< [ too-high ] [ too-low ] ifte ;
|
< [ too-high ] [ too-low ] ifte ;
|
||||||
|
|
||||||
: judge-guess ( actual guess -- ? )
|
: judge-guess ( actual guess -- ? )
|
||||||
2dup = [
|
2dup = [ 2drop correct f ] [ inexact-guess t ] ifte ;
|
||||||
2drop correct f
|
|
||||||
] [
|
|
||||||
inexact-guess t
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: number-to-guess ( -- n ) 0 100 random-int ;
|
: number-to-guess ( -- n ) 0 100 random-int ;
|
||||||
|
|
||||||
: numbers-game-loop ( actual -- )
|
: numbers-game-loop ( actual -- )
|
||||||
dup guess-prompt read-number judge-guess [
|
dup guess-prompt read-number judge-guess
|
||||||
numbers-game-loop
|
[ numbers-game-loop ] [ drop ] ifte ;
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: numbers-game number-to-guess numbers-game-loop ;
|
: numbers-game number-to-guess numbers-game-loop ;
|
||||||
|
|
|
||||||
|
|
@ -152,3 +152,5 @@ SYMBOL: theta
|
||||||
make-plot
|
make-plot
|
||||||
<event> event-loop SDL_Quit
|
<event> event-loop SDL_Quit
|
||||||
] with-screen ;
|
] with-screen ;
|
||||||
|
|
||||||
|
plot3d
|
||||||
|
|
|
||||||
|
|
@ -1,46 +0,0 @@
|
||||||
! :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 ;
|
|
||||||
|
|
@ -1,67 +0,0 @@
|
||||||
! 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 ;
|
|
||||||
Loading…
Reference in New Issue