updated examples
Slava Pestov
parent
f2f1c6705b
commit
06fd239a6f
|
|
@ -17,16 +17,7 @@
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
{
|
||||
" _ _ _ _ _ _ _ _ "
|
||||
" | | | _| _| |_| |_ |_ | |_| |_| "
|
||||
" |_| | |_ _| | _| |_| | |_| | "
|
||||
} 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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 ;
|
||||
|
|
@ -16,19 +14,12 @@ USING: kernel math parser random io ;
|
|||
< [ 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 ;
|
||||
|
|
|
|||
|
|
@ -152,3 +152,5 @@ SYMBOL: theta
|
|||
make-plot
|
||||
<event> event-loop SDL_Quit
|
||||
] 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