Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
2a9f92f4cc
|
|
@ -88,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- )
|
|||
disjoint-set link-sets
|
||||
] if ;
|
||||
|
||||
: equate-all-with ( seq a disjoint-set -- )
|
||||
'[ , , equate ] each ;
|
||||
|
||||
: equate-all ( seq disjoint-set -- )
|
||||
over dup empty? [ 2drop ] [
|
||||
[ unclip-slice ] dip equate-all-with
|
||||
] if ;
|
||||
|
||||
M: disjoint-set clone
|
||||
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
|
||||
disjoint-set boa ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,27 @@
|
|||
USING: help.syntax help.markup ;
|
||||
USING: help.syntax help.markup arrays sequences ;
|
||||
|
||||
IN: math.ranges
|
||||
|
||||
ARTICLE: "ranges" "Ranges"
|
||||
|
||||
"A " { $emphasis "range" } " is a virtual sequence with real elements "
|
||||
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
|
||||
|
||||
$nl
|
||||
|
||||
"Creating ranges:"
|
||||
|
||||
{ $subsection <range> }
|
||||
{ $subsection [a,b] }
|
||||
{ $subsection (a,b] }
|
||||
{ $subsection [a,b) }
|
||||
{ $subsection (a,b) }
|
||||
{ $subsection [0,b] }
|
||||
{ $subsection [1,b] }
|
||||
{ $subsection [0,b) } ;
|
||||
"A " { $emphasis "range" } " is a virtual sequence with real number elements "
|
||||
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
|
||||
$nl
|
||||
"The class of ranges:"
|
||||
{ $subsection range }
|
||||
"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
|
||||
{ $subsection [a,b] }
|
||||
{ $subsection (a,b] }
|
||||
{ $subsection [a,b) }
|
||||
{ $subsection (a,b) }
|
||||
{ $subsection [0,b] }
|
||||
{ $subsection [1,b] }
|
||||
{ $subsection [0,b) }
|
||||
"Creating general ranges:"
|
||||
{ $subsection <range> }
|
||||
"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
|
||||
{ $code
|
||||
"3 10 [a,b] [ sqrt ] map"
|
||||
}
|
||||
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
|
||||
|
||||
ABOUT: "ranges"
|
||||
|
|
@ -7,13 +7,15 @@ IN: unix
|
|||
|
||||
: MAXPATHLEN 1024 ; inline
|
||||
|
||||
: O_RDONLY HEX: 0000 ; inline
|
||||
: O_WRONLY HEX: 0001 ; inline
|
||||
: O_RDWR HEX: 0002 ; inline
|
||||
: O_APPEND HEX: 0008 ; inline
|
||||
: O_CREAT HEX: 0200 ; inline
|
||||
: O_TRUNC HEX: 0400 ; inline
|
||||
: O_EXCL HEX: 0800 ; inline
|
||||
: O_RDONLY HEX: 0000 ; inline
|
||||
: O_WRONLY HEX: 0001 ; inline
|
||||
: O_RDWR HEX: 0002 ; inline
|
||||
: O_NONBLOCK HEX: 0004 ; inline
|
||||
: O_APPEND HEX: 0008 ; inline
|
||||
: O_CREAT HEX: 0200 ; inline
|
||||
: O_TRUNC HEX: 0400 ; inline
|
||||
: O_EXCL HEX: 0800 ; inline
|
||||
: O_NOCTTY HEX: 20000 ; inline
|
||||
|
||||
: SOL_SOCKET HEX: ffff ; inline
|
||||
: SO_REUSEADDR HEX: 4 ; inline
|
||||
|
|
@ -24,7 +26,6 @@ IN: unix
|
|||
: F_SETFD 2 ; inline
|
||||
: F_SETFL 4 ; inline
|
||||
: FD_CLOEXEC 1 ; inline
|
||||
: O_NONBLOCK 4 ; inline
|
||||
|
||||
C-STRUCT: sockaddr-in
|
||||
{ "uchar" "len" }
|
||||
|
|
|
|||
|
|
@ -7,13 +7,15 @@ USING: alien.syntax ;
|
|||
|
||||
: MAXPATHLEN 1024 ; inline
|
||||
|
||||
: O_RDONLY HEX: 0000 ; inline
|
||||
: O_WRONLY HEX: 0001 ; inline
|
||||
: O_RDWR HEX: 0002 ; inline
|
||||
: O_CREAT HEX: 0040 ; inline
|
||||
: O_EXCL HEX: 0080 ; inline
|
||||
: O_TRUNC HEX: 0200 ; inline
|
||||
: O_APPEND HEX: 0400 ; inline
|
||||
: O_RDONLY HEX: 0000 ; inline
|
||||
: O_WRONLY HEX: 0001 ; inline
|
||||
: O_RDWR HEX: 0002 ; inline
|
||||
: O_CREAT HEX: 0040 ; inline
|
||||
: O_EXCL HEX: 0080 ; inline
|
||||
: O_NOCTTY HEX: 0100 ; inline
|
||||
: O_TRUNC HEX: 0200 ; inline
|
||||
: O_APPEND HEX: 0400 ; inline
|
||||
: O_NONBLOCK HEX: 0800 ; inline
|
||||
|
||||
: SOL_SOCKET 1 ; inline
|
||||
|
||||
|
|
@ -28,7 +30,6 @@ USING: alien.syntax ;
|
|||
: FD_CLOEXEC 1 ; inline
|
||||
|
||||
: F_SETFL 4 ; inline
|
||||
: O_NONBLOCK HEX: 800 ; inline
|
||||
|
||||
C-STRUCT: addrinfo
|
||||
{ "int" "flags" }
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@ TYPEDEF: uint socklen_t
|
|||
|
||||
: NGROUPS_MAX 16 ; inline
|
||||
|
||||
: O_NDELAY O_NONBLOCK ; inline
|
||||
|
||||
C-STRUCT: group
|
||||
{ "char*" "gr_name" }
|
||||
{ "char*" "gr_passwd" }
|
||||
|
|
|
|||
|
|
@ -31,12 +31,12 @@ HELP: 24-able ( -- vector )
|
|||
"just using the provided commands and the 4 numbers. The Following are the "
|
||||
"provided commands: "
|
||||
{ $link + } ", " { $link - } ", " { $link * } ", "
|
||||
{ $link / } ", and " { $link swap } "."
|
||||
{ $link / } ", " { $link swap } ", and " { $link rot } "."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USE: 24-game"
|
||||
"24-able vector-24-able?"
|
||||
"24-able vector-24-able? ."
|
||||
"t"
|
||||
}
|
||||
{ $notes { $link 24-able? } " is used in " { $link 24-able } "." }
|
||||
|
|
|
|||
|
|
@ -59,4 +59,5 @@ DEFER: check-status
|
|||
: 24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
|
||||
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
|
||||
: set-commands ( -- ) { + - * / rot swap q } commands set ;
|
||||
: play-game ( -- ) set-commands 24-able repeat ;
|
||||
: play-game ( -- ) set-commands 24-able repeat ;
|
||||
MAIN: play-game
|
||||
|
|
@ -1,34 +1,65 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: extra.animations
|
||||
IN: animations
|
||||
|
||||
HELP: animate ( quot duration -- )
|
||||
|
||||
{ $values
|
||||
{ "quot" "a quot which uses " { $link progress } }
|
||||
{ "duration" "a duration of time" }
|
||||
}
|
||||
{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once." }
|
||||
{ $example
|
||||
"USING: extra.animations calendar threads prettyprint ;"
|
||||
"[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;"
|
||||
"46 ms elapsed\n17 ms elapsed"
|
||||
{ $description
|
||||
{ $link animate } " calls " { $link reset-progress }
|
||||
" , then continously calls the given quot until the"
|
||||
" duration of time has elapsed. The quot should use "
|
||||
{ $link progress } " at least once."
|
||||
}
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: animations calendar threads prettyprint ;"
|
||||
"[ 1 sleep progress unparse write \" ms elapsed\" print ] "
|
||||
"1/20 seconds animate ;"
|
||||
"46 ms elapsed\n17 ms elapsed"
|
||||
}
|
||||
{ $notes "The amount of time elapsed between these iterations will very." }
|
||||
} ;
|
||||
|
||||
HELP: reset-progress ( -- )
|
||||
{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ;
|
||||
{ $description
|
||||
"Initiates the timer. Call this before using "
|
||||
"a loop which makes use of " { $link progress } "."
|
||||
} ;
|
||||
|
||||
HELP: progress ( -- time )
|
||||
{ $values { "time" "an integer" } }
|
||||
{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." }
|
||||
{ $example
|
||||
"USING: extra.animations threads prettyprint ;"
|
||||
"reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;"
|
||||
"31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
|
||||
{ $description
|
||||
"Gives the time elapsed since the last time"
|
||||
" this word was called, in milliseconds."
|
||||
}
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: animations threads prettyprint ;"
|
||||
"reset-progress 3 "
|
||||
"[ 1 sleep progress unparse write \"ms elapsed\" print ] "
|
||||
"times ;"
|
||||
"31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
|
||||
}
|
||||
{ $notes "The amount of time elapsed between these iterations will very." }
|
||||
} ;
|
||||
|
||||
ARTICLE: "extra.animations" "Animations"
|
||||
"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!"
|
||||
ARTICLE: "animations" "Animations"
|
||||
"Provides a lightweight framework for properly simulating continuous"
|
||||
" functions of real time. This framework helps one create animations "
|
||||
"that use rates which do not change across platforms. The speed of the "
|
||||
"computer should correlate with the smoothness of the animation, not "
|
||||
"the speed of the animation!"
|
||||
{ $subsection animate }
|
||||
{ $subsection reset-progress }
|
||||
{ $subsection progress }
|
||||
{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ;
|
||||
ABOUT: "extra.animations"
|
||||
! A little talk about when to use progress and when to use animate
|
||||
{ $link progress } " specifically provides the length of time since "
|
||||
{ $link reset-progress } " was called, and also calls "
|
||||
{ $link reset-progress } " as its last action. This can be directly "
|
||||
"used when one's quote runs for a specific number of iterations, instead "
|
||||
"of a length of time. If the animation is like most, and is expected to "
|
||||
"run for a specific length of time, " { $link animate } " should be used." ;
|
||||
ABOUT: "animations"
|
||||
|
|
@ -2,11 +2,16 @@
|
|||
|
||||
USING: kernel shuffle system locals
|
||||
prettyprint math io namespaces threads calendar ;
|
||||
IN: extra.animations
|
||||
IN: animations
|
||||
|
||||
SYMBOL: last-loop
|
||||
SYMBOL: sleep-period
|
||||
|
||||
: reset-progress ( -- ) millis last-loop set ;
|
||||
! : my-progress ( -- progress ) millis
|
||||
: progress ( -- progress ) millis last-loop get - reset-progress ;
|
||||
: progress-peek ( -- progress ) millis last-loop get - ;
|
||||
: set-end ( duration -- end-time ) dt>milliseconds millis + ;
|
||||
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ;
|
||||
: animate ( quot duration -- ) reset-progress set-end loop ;
|
||||
: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
|
||||
: animate ( quot duration -- ) reset-progress set-end loop ; inline
|
||||
: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline
|
||||
|
|
@ -1 +1 @@
|
|||
Reginald Keith Ford II
|
||||
Reginald Ford
|
||||
|
|
@ -46,7 +46,7 @@ GENERIC: irc-command-parameters ( irc-message -- seq )
|
|||
M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
|
||||
M: ping irc-command-parameters ( ping -- seq ) drop { } ;
|
||||
M: join irc-command-parameters ( join -- seq ) drop { } ;
|
||||
M: part irc-command-parameters ( part -- seq ) name>> 1array ;
|
||||
M: part irc-command-parameters ( part -- seq ) channel>> 1array ;
|
||||
M: quit irc-command-parameters ( quit -- seq ) drop { } ;
|
||||
M: nick irc-command-parameters ( nick -- seq ) drop { } ;
|
||||
M: privmsg irc-command-parameters ( privmsg -- seq ) name>> 1array ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 William Schlieper
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors kernel irc.client irc.messages irc.ui namespaces ;
|
||||
USING: accessors kernel arrays irc.client irc.messages irc.ui namespaces ;
|
||||
|
||||
IN: irc.ui.commands
|
||||
|
||||
|
|
@ -16,5 +16,9 @@ IN: irc.ui.commands
|
|||
: query ( string -- )
|
||||
irc-tab get window>> query-nick ;
|
||||
|
||||
: whois ( string -- )
|
||||
"WHOIS" swap { } clone swap <irc-client-message>
|
||||
irc-tab get listener>> write-message ;
|
||||
|
||||
: quote ( string -- )
|
||||
drop ; ! THIS WILL CHANGE
|
||||
|
|
|
|||
|
|
@ -13,11 +13,6 @@ IN: math.combinatorics.tests
|
|||
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
|
||||
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
|
||||
|
||||
[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test
|
||||
[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test
|
||||
[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test
|
||||
[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test
|
||||
|
||||
[ 1 ] [ 0 factorial ] unit-test
|
||||
[ 1 ] [ 1 factorial ] unit-test
|
||||
[ 3628800 ] [ 10 factorial ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math math.order math.ranges mirrors
|
||||
namespaces sequences sorting ;
|
||||
namespaces sequences sequences.lib sorting ;
|
||||
IN: math.combinatorics
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -27,9 +27,6 @@ IN: math.combinatorics
|
|||
: permutation-indices ( n seq -- permutation )
|
||||
length [ factoradic ] dip 0 pad-left >permutation ;
|
||||
|
||||
: reorder ( seq indices -- seq )
|
||||
[ [ over nth , ] each drop ] { } make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: factorial ( n -- n! )
|
||||
|
|
@ -42,7 +39,7 @@ PRIVATE>
|
|||
twiddle [ nPk ] keep factorial / ;
|
||||
|
||||
: permutation ( n seq -- seq )
|
||||
tuck permutation-indices reorder ;
|
||||
tuck permutation-indices nths ;
|
||||
|
||||
: all-permutations ( seq -- seq )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Reginald Ford
|
||||
Reginald Ford
|
||||
Eduardo Cavazos
|
||||
|
|
@ -1,9 +1,101 @@
|
|||
USING: help.markup help.syntax ;
|
||||
|
||||
USING: help.markup help.syntax math.functions ;
|
||||
IN: math.derivatives
|
||||
|
||||
HELP: derivative ( x function -- m )
|
||||
{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
|
||||
{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
|
||||
{ $values { "x" "a position on the function" } { "function" "a differentiable function" } }
|
||||
{ $description
|
||||
"Approximates the slope of the tangent line by using Ridders' "
|
||||
"method of computing derivatives, from the chapter \"Accurate computation "
|
||||
"of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, Vol. 4, pp. 75-76 ."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: math.derivatives prettyprint ;"
|
||||
"[ sq ] 4 derivative ."
|
||||
"8"
|
||||
}
|
||||
{ $notes
|
||||
"For applied scientists, you may play with the settings "
|
||||
"in the source file to achieve arbitrary accuracy. "
|
||||
}
|
||||
} ;
|
||||
|
||||
{ derivative-func } related-words
|
||||
HELP: (derivative) ( x function h err -- m )
|
||||
{ $values
|
||||
{ "x" "a position on the function" }
|
||||
{ "function" "a differentiable function" }
|
||||
{
|
||||
"h" "distance between the points of the first secant line used for "
|
||||
"approximation of the tangent. This distance will be divided "
|
||||
"constantly, by " { $link con } ". See " { $link init-hh }
|
||||
" for the code which enforces this. H should be .001 to .5 -- too "
|
||||
"small can cause bad convergence. Also, h should be small enough "
|
||||
"to give the correct sgn(f'(x)). In other words, if you're expecting "
|
||||
"a positive derivative, make h small enough to give the same "
|
||||
"when plugged into the academic limit definition of a derivative. "
|
||||
"See " { $link update-hh } " for the code which performs this task."
|
||||
}
|
||||
{
|
||||
"err" "maximum tolerance of increase in error. For example, if this "
|
||||
"is set to 2.0, the program will terminate with its nearest answer "
|
||||
"when the error multiplies by 2. See " { $link check-safe } " for "
|
||||
"the enforcing code."
|
||||
}
|
||||
}
|
||||
{ $description
|
||||
"Approximates the slope of the tangent line by using Ridders' "
|
||||
"method of computing derivatives, from the chapter \"Accurate computation "
|
||||
"of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, "
|
||||
"Vol. 4, pp. 75-76 ."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: math.derivatives prettyprint ;"
|
||||
"[ sq ] 4 derivative ."
|
||||
"8"
|
||||
}
|
||||
{ $notes
|
||||
"For applied scientists, you may play with the settings "
|
||||
"in the source file to achieve arbitrary accuracy. "
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: derivative-func ( function -- der )
|
||||
{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
|
||||
{ $description
|
||||
"Provides the derivative of the function. The implementation simply "
|
||||
"attaches the " { $link derivative } " word to the end of the function."
|
||||
}
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: math.derivatives prettyprint ;"
|
||||
"60 deg>rad [ sin ] derivative-func call ."
|
||||
"0.5000000000000173"
|
||||
}
|
||||
{ $notes
|
||||
"Without a heavy algebraic system, derivatives must be "
|
||||
"approximated. With the current settings, there is a fair trade of "
|
||||
"speed and accuracy; the first 12 digits "
|
||||
"will always be correct with " { $link sin } " and " { $link cos }
|
||||
". The following code performs a minumum and maximum error test."
|
||||
{ $code
|
||||
"USING: kernel math math.functions math.trig sequences sequences.lib ;"
|
||||
"360"
|
||||
"["
|
||||
" deg>rad"
|
||||
" [ [ sin ] derivative-func call ]"
|
||||
" ! Note: the derivative of sin is cos"
|
||||
" [ cos ]"
|
||||
" bi - abs"
|
||||
"] map minmax"
|
||||
|
||||
}
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "derivatives" "The Derivative Toolkit"
|
||||
"A toolkit for computing the derivative of functions."
|
||||
{ $subsection derivative }
|
||||
{ $subsection derivative-func }
|
||||
{ $subsection (derivative) } ;
|
||||
ABOUT: "derivatives"
|
||||
|
|
|
|||
|
|
@ -1,10 +1,123 @@
|
|||
! Copyright © 2008 Reginald Keith Ford II
|
||||
! Tool for computing the derivative of a function at a point
|
||||
USING: kernel math math.points math.function-tools ;
|
||||
|
||||
USING: kernel continuations combinators sequences math
|
||||
math.order math.ranges accessors float-arrays ;
|
||||
|
||||
IN: math.derivatives
|
||||
|
||||
: small-amount ( -- n ) 1.0e-14 ;
|
||||
: some-more ( x -- y ) small-amount + ;
|
||||
: some-less ( x -- y ) small-amount - ;
|
||||
: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ;
|
||||
: derivative-func ( function -- function ) [ derivative ] curry ;
|
||||
TUPLE: state x func h err i j errt fac hh ans a done ;
|
||||
|
||||
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
|
||||
: ntab ( -- val ) 8 ;
|
||||
: con ( -- val ) 1.6 ;
|
||||
: con2 ( -- val ) con con * ;
|
||||
: big ( -- val ) largest-float ;
|
||||
: safe ( -- val ) 2.0 ;
|
||||
|
||||
! Yes, this was ported from C code.
|
||||
: a[i][i] ( state -- elt ) [ i>> ] [ i>> ] [ a>> ] tri nth nth ;
|
||||
: a[j][i] ( state -- elt ) [ i>> ] [ j>> ] [ a>> ] tri nth nth ;
|
||||
: a[j-1][i] ( state -- elt ) [ i>> ] [ j>> 1 - ] [ a>> ] tri nth nth ;
|
||||
: a[j-1][i-1] ( state -- elt ) [ i>> 1 - ] [ j>> 1 - ] [ a>> ] tri nth nth ;
|
||||
: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
|
||||
|
||||
: check-h ( state -- state )
|
||||
dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
|
||||
: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
|
||||
: init-hh ( state -- state ) dup h>> >>hh ;
|
||||
: init-err ( state -- state ) big >>err ;
|
||||
: update-hh ( state -- state ) dup hh>> con / >>hh ;
|
||||
: reset-fac ( state -- state ) con2 >>fac ;
|
||||
: update-fac ( state -- state ) dup fac>> con2 * >>fac ;
|
||||
|
||||
! If error is decreased, save the improved answer
|
||||
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
|
||||
: save-improved-answer ( state -- state )
|
||||
dup err>> >>errt
|
||||
dup a[j][i] >>ans ;
|
||||
|
||||
! If higher order is worse by a significant factor SAFE, then quit early.
|
||||
: check-safe ( state -- state )
|
||||
dup
|
||||
[ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
|
||||
[ t >>done ]
|
||||
when ;
|
||||
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
|
||||
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
|
||||
: limit-approx ( state -- val )
|
||||
[
|
||||
[ [ x+hh ] [ func>> ] bi call ]
|
||||
[ [ x-hh ] [ func>> ] bi call ]
|
||||
bi -
|
||||
]
|
||||
[ hh>> 2.0 * ]
|
||||
bi / ;
|
||||
: a[0][0]! ( state -- state )
|
||||
{ [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
|
||||
: a[0][i]! ( state -- state )
|
||||
{ [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
|
||||
: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
|
||||
: new-a[j][i] ( state -- val )
|
||||
[ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
|
||||
[ fac>> 1.0 - ]
|
||||
bi / ;
|
||||
: a[j][i]! ( state -- state )
|
||||
{ [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
|
||||
|
||||
: update-errt ( state -- state )
|
||||
dup
|
||||
[ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
|
||||
[ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
|
||||
bi max
|
||||
>>errt ;
|
||||
|
||||
: not-done? ( state -- state ? ) dup done>> not ;
|
||||
|
||||
: derive ( state -- state )
|
||||
init-a
|
||||
check-h
|
||||
init-hh
|
||||
a[0][0]!
|
||||
init-err
|
||||
1 ntab [a,b)
|
||||
[
|
||||
>>i
|
||||
not-done?
|
||||
[
|
||||
update-hh
|
||||
a[0][i]!
|
||||
reset-fac
|
||||
1 over i>> [a,b]
|
||||
[
|
||||
>>j
|
||||
a[j][i]!
|
||||
update-fac
|
||||
update-errt
|
||||
error-decreased? [ save-improved-answer ] when
|
||||
]
|
||||
each
|
||||
check-safe
|
||||
]
|
||||
when
|
||||
]
|
||||
each ;
|
||||
|
||||
: derivative-state ( x func h err -- state )
|
||||
state new
|
||||
swap >>err
|
||||
swap >>h
|
||||
swap >>func
|
||||
swap >>x ;
|
||||
|
||||
! For scientists:
|
||||
! h should be .001 to .5 -- too small can cause bad convergence,
|
||||
! h should be small enough to give the correct sgn(f'(x))
|
||||
! err is the max tolerance of gain in error for a single iteration-
|
||||
: (derivative) ( x func h err -- ans error )
|
||||
derivative-state
|
||||
derive
|
||||
[ ans>> ]
|
||||
[ errt>> ]
|
||||
bi ;
|
||||
|
||||
: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
|
||||
: derivative-func ( func -- der ) [ derivative ] curry ;
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
|
||||
USING: kernel math arrays sequences sequences.lib ;
|
||||
IN: math.function-tools
|
||||
: difference-func ( func func -- func ) [ bi - ] 2curry ;
|
||||
: eval ( x func -- pt ) dupd call 2array ;
|
||||
: eval-inverse ( y func -- pt ) dupd call swap 2array ;
|
||||
: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
|
||||
: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
|
||||
: eval ( x func -- pt ) dupd call 2array ; inline
|
||||
: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
|
||||
: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types assocs combinators destructors
|
||||
kernel math math.bitfields math.parser sequences summary system
|
||||
vocabs.loader ;
|
||||
IN: serial
|
||||
|
||||
TUPLE: serial stream path baud
|
||||
termios iflag oflag cflag lflag ;
|
||||
|
||||
ERROR: invalid-baud baud ;
|
||||
M: invalid-baud summary ( invalid-baud -- string )
|
||||
"Baud rate "
|
||||
swap baud>> number>string
|
||||
" not supported" 3append ;
|
||||
|
||||
HOOK: lookup-baud os ( m -- n )
|
||||
HOOK: open-serial os ( serial -- serial' )
|
||||
M: serial dispose ( serial -- ) stream>> dispose ;
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "serial.unix" ] }
|
||||
} cond require
|
||||
|
|
@ -0,0 +1 @@
|
|||
Serial port library
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel math.bitfields sequences system serial ;
|
||||
IN: serial.unix
|
||||
|
||||
M: bsd lookup-baud ( m -- n )
|
||||
dup {
|
||||
0 50 75 110 134 150 200 300 600 1200 1800 2400 4800
|
||||
7200 9600 14400 19200 28800 38400 57600 76800 115200
|
||||
230400 460800 921600
|
||||
} member? [ invalid-baud ] unless ;
|
||||
|
||||
: TCSANOW 0 ; inline
|
||||
: TCSADRAIN 1 ; inline
|
||||
: TCSAFLUSH 2 ; inline
|
||||
: TCSASOFT HEX: 10 ; inline
|
||||
|
||||
: TCIFLUSH 1 ; inline
|
||||
: TCOFLUSH 2 ; inline
|
||||
: TCIOFLUSH 3 ; inline
|
||||
: TCOOFF 1 ; inline
|
||||
: TCOON 2 ; inline
|
||||
: TCIOFF 3 ; inline
|
||||
: TCION 4 ; inline
|
||||
|
||||
! iflags
|
||||
: IGNBRK HEX: 00000001 ; inline
|
||||
: BRKINT HEX: 00000002 ; inline
|
||||
: IGNPAR HEX: 00000004 ; inline
|
||||
: PARMRK HEX: 00000008 ; inline
|
||||
: INPCK HEX: 00000010 ; inline
|
||||
: ISTRIP HEX: 00000020 ; inline
|
||||
: INLCR HEX: 00000040 ; inline
|
||||
: IGNCR HEX: 00000080 ; inline
|
||||
: ICRNL HEX: 00000100 ; inline
|
||||
: IXON HEX: 00000200 ; inline
|
||||
: IXOFF HEX: 00000400 ; inline
|
||||
: IXANY HEX: 00000800 ; inline
|
||||
: IMAXBEL HEX: 00002000 ; inline
|
||||
: IUTF8 HEX: 00004000 ; inline
|
||||
|
||||
! oflags
|
||||
: OPOST HEX: 00000001 ; inline
|
||||
: ONLCR HEX: 00000002 ; inline
|
||||
: OXTABS HEX: 00000004 ; inline
|
||||
: ONOEOT HEX: 00000008 ; inline
|
||||
|
||||
! cflags
|
||||
: CIGNORE HEX: 00000001 ; inline
|
||||
: CSIZE HEX: 00000300 ; inline
|
||||
: CS5 HEX: 00000000 ; inline
|
||||
: CS6 HEX: 00000100 ; inline
|
||||
: CS7 HEX: 00000200 ; inline
|
||||
: CS8 HEX: 00000300 ; inline
|
||||
: CSTOPB HEX: 00000400 ; inline
|
||||
: CREAD HEX: 00000800 ; inline
|
||||
: PARENB HEX: 00001000 ; inline
|
||||
: PARODD HEX: 00002000 ; inline
|
||||
: HUPCL HEX: 00004000 ; inline
|
||||
: CLOCAL HEX: 00008000 ; inline
|
||||
: CCTS_OFLOW HEX: 00010000 ; inline
|
||||
: CRTS_IFLOW HEX: 00020000 ; inline
|
||||
: CRTSCTS { CCTS_OFLOW CRTS_IFLOW } flags ; inline
|
||||
: CDTR_IFLOW HEX: 00040000 ; inline
|
||||
: CDSR_OFLOW HEX: 00080000 ; inline
|
||||
: CCAR_OFLOW HEX: 00100000 ; inline
|
||||
: MDMBUF HEX: 00100000 ; inline
|
||||
|
||||
! lflags
|
||||
: ECHOKE HEX: 00000001 ; inline
|
||||
: ECHOE HEX: 00000002 ; inline
|
||||
: ECHOK HEX: 00000004 ; inline
|
||||
: ECHO HEX: 00000008 ; inline
|
||||
: ECHONL HEX: 00000010 ; inline
|
||||
: ECHOPRT HEX: 00000020 ; inline
|
||||
: ECHOCTL HEX: 00000040 ; inline
|
||||
: ISIG HEX: 00000080 ; inline
|
||||
: ICANON HEX: 00000100 ; inline
|
||||
: ALTWERASE HEX: 00000200 ; inline
|
||||
: IEXTEN HEX: 00000400 ; inline
|
||||
: EXTPROC HEX: 00000800 ; inline
|
||||
: TOSTOP HEX: 00400000 ; inline
|
||||
: FLUSHO HEX: 00800000 ; inline
|
||||
: NOKERNINFO HEX: 02000000 ; inline
|
||||
: PENDIN HEX: 20000000 ; inline
|
||||
: NOFLSH HEX: 80000000 ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,130 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs alien.syntax kernel serial system unix ;
|
||||
IN: serial.unix
|
||||
|
||||
: TCSANOW 0 ; inline
|
||||
: TCSADRAIN 1 ; inline
|
||||
: TCSAFLUSH 2 ; inline
|
||||
|
||||
: TCIFLUSH 0 ; inline
|
||||
: TCOFLUSH 1 ; inline
|
||||
: TCIOFLUSH 2 ; inline
|
||||
|
||||
: TCOOFF 0 ; inline
|
||||
: TCOON 1 ; inline
|
||||
: TCIOFF 2 ; inline
|
||||
: TCION 3 ; inline
|
||||
|
||||
! iflag
|
||||
: IGNBRK OCT: 0000001 ; inline
|
||||
: BRKINT OCT: 0000002 ; inline
|
||||
: IGNPAR OCT: 0000004 ; inline
|
||||
: PARMRK OCT: 0000010 ; inline
|
||||
: INPCK OCT: 0000020 ; inline
|
||||
: ISTRIP OCT: 0000040 ; inline
|
||||
: INLCR OCT: 0000100 ; inline
|
||||
: IGNCR OCT: 0000200 ; inline
|
||||
: ICRNL OCT: 0000400 ; inline
|
||||
: IUCLC OCT: 0001000 ; inline
|
||||
: IXON OCT: 0002000 ; inline
|
||||
: IXANY OCT: 0004000 ; inline
|
||||
: IXOFF OCT: 0010000 ; inline
|
||||
: IMAXBEL OCT: 0020000 ; inline
|
||||
: IUTF8 OCT: 0040000 ; inline
|
||||
|
||||
! oflag
|
||||
: OPOST OCT: 0000001 ; inline
|
||||
: OLCUC OCT: 0000002 ; inline
|
||||
: ONLCR OCT: 0000004 ; inline
|
||||
: OCRNL OCT: 0000010 ; inline
|
||||
: ONOCR OCT: 0000020 ; inline
|
||||
: ONLRET OCT: 0000040 ; inline
|
||||
: OFILL OCT: 0000100 ; inline
|
||||
: OFDEL OCT: 0000200 ; inline
|
||||
: NLDLY OCT: 0000400 ; inline
|
||||
: NL0 OCT: 0000000 ; inline
|
||||
: NL1 OCT: 0000400 ; inline
|
||||
: CRDLY OCT: 0003000 ; inline
|
||||
: CR0 OCT: 0000000 ; inline
|
||||
: CR1 OCT: 0001000 ; inline
|
||||
: CR2 OCT: 0002000 ; inline
|
||||
: CR3 OCT: 0003000 ; inline
|
||||
: TABDLY OCT: 0014000 ; inline
|
||||
: TAB0 OCT: 0000000 ; inline
|
||||
: TAB1 OCT: 0004000 ; inline
|
||||
: TAB2 OCT: 0010000 ; inline
|
||||
: TAB3 OCT: 0014000 ; inline
|
||||
: BSDLY OCT: 0020000 ; inline
|
||||
: BS0 OCT: 0000000 ; inline
|
||||
: BS1 OCT: 0020000 ; inline
|
||||
: FFDLY OCT: 0100000 ; inline
|
||||
: FF0 OCT: 0000000 ; inline
|
||||
: FF1 OCT: 0100000 ; inline
|
||||
|
||||
! cflags
|
||||
: CSIZE OCT: 0000060 ; inline
|
||||
: CS5 OCT: 0000000 ; inline
|
||||
: CS6 OCT: 0000020 ; inline
|
||||
: CS7 OCT: 0000040 ; inline
|
||||
: CS8 OCT: 0000060 ; inline
|
||||
: CSTOPB OCT: 0000100 ; inline
|
||||
: CREAD OCT: 0000200 ; inline
|
||||
: PARENB OCT: 0000400 ; inline
|
||||
: PARODD OCT: 0001000 ; inline
|
||||
: HUPCL OCT: 0002000 ; inline
|
||||
: CLOCAL OCT: 0004000 ; inline
|
||||
: CIBAUD OCT: 002003600000 ; inline
|
||||
: CRTSCTS OCT: 020000000000 ; inline
|
||||
|
||||
! lflags
|
||||
: ISIG OCT: 0000001 ; inline
|
||||
: ICANON OCT: 0000002 ; inline
|
||||
: XCASE OCT: 0000004 ; inline
|
||||
: ECHO OCT: 0000010 ; inline
|
||||
: ECHOE OCT: 0000020 ; inline
|
||||
: ECHOK OCT: 0000040 ; inline
|
||||
: ECHONL OCT: 0000100 ; inline
|
||||
: NOFLSH OCT: 0000200 ; inline
|
||||
: TOSTOP OCT: 0000400 ; inline
|
||||
: ECHOCTL OCT: 0001000 ; inline
|
||||
: ECHOPRT OCT: 0002000 ; inline
|
||||
: ECHOKE OCT: 0004000 ; inline
|
||||
: FLUSHO OCT: 0010000 ; inline
|
||||
: PENDIN OCT: 0040000 ; inline
|
||||
: IEXTEN OCT: 0100000 ; inline
|
||||
|
||||
M: linux lookup-baud ( n -- n )
|
||||
dup H{
|
||||
{ 0 OCT: 0000000 }
|
||||
{ 50 OCT: 0000001 }
|
||||
{ 75 OCT: 0000002 }
|
||||
{ 110 OCT: 0000003 }
|
||||
{ 134 OCT: 0000004 }
|
||||
{ 150 OCT: 0000005 }
|
||||
{ 200 OCT: 0000006 }
|
||||
{ 300 OCT: 0000007 }
|
||||
{ 600 OCT: 0000010 }
|
||||
{ 1200 OCT: 0000011 }
|
||||
{ 1800 OCT: 0000012 }
|
||||
{ 2400 OCT: 0000013 }
|
||||
{ 4800 OCT: 0000014 }
|
||||
{ 9600 OCT: 0000015 }
|
||||
{ 19200 OCT: 0000016 }
|
||||
{ 38400 OCT: 0000017 }
|
||||
{ 57600 OCT: 0010001 }
|
||||
{ 115200 OCT: 0010002 }
|
||||
{ 230400 OCT: 0010003 }
|
||||
{ 460800 OCT: 0010004 }
|
||||
{ 500000 OCT: 0010005 }
|
||||
{ 576000 OCT: 0010006 }
|
||||
{ 921600 OCT: 0010007 }
|
||||
{ 1000000 OCT: 0010010 }
|
||||
{ 1152000 OCT: 0010011 }
|
||||
{ 1500000 OCT: 0010012 }
|
||||
{ 2000000 OCT: 0010013 }
|
||||
{ 2500000 OCT: 0010014 }
|
||||
{ 3000000 OCT: 0010015 }
|
||||
{ 3500000 OCT: 0010016 }
|
||||
{ 4000000 OCT: 0010017 }
|
||||
} at* [ nip ] [ drop invalid-baud ] if ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel sequences system ;
|
||||
IN: serial.unix.termios
|
||||
|
||||
: NCCS 20 ; inline
|
||||
|
||||
TYPEDEF: uint tcflag_t
|
||||
TYPEDEF: uchar cc_t
|
||||
TYPEDEF: uint speed_t
|
||||
|
||||
C-STRUCT: termios
|
||||
{ "tcflag_t" "iflag" } ! input mode flags
|
||||
{ "tcflag_t" "oflag" } ! output mode flags
|
||||
{ "tcflag_t" "cflag" } ! control mode flags
|
||||
{ "tcflag_t" "lflag" } ! local mode flags
|
||||
{ { "cc_t" NCCS } "cc" } ! control characters
|
||||
{ "speed_t" "ispeed" } ! input speed
|
||||
{ "speed_t" "ospeed" } ; ! output speed
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel system unix ;
|
||||
IN: serial.unix.termios
|
||||
|
||||
: NCCS 32 ; inline
|
||||
|
||||
TYPEDEF: uchar cc_t
|
||||
TYPEDEF: uint speed_t
|
||||
TYPEDEF: uint tcflag_t
|
||||
|
||||
C-STRUCT: termios
|
||||
{ "tcflag_t" "iflag" } ! input mode flags
|
||||
{ "tcflag_t" "oflag" } ! output mode flags
|
||||
{ "tcflag_t" "cflag" } ! control mode flags
|
||||
{ "tcflag_t" "lflag" } ! local mode flags
|
||||
{ "cc_t" "line" } ! line discipline
|
||||
{ { "cc_t" NCCS } "cc" } ! control characters
|
||||
{ "speed_t" "ispeed" } ! input speed
|
||||
{ "speed_t" "ospeed" } ; ! output speed
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators system vocabs.loader ;
|
||||
IN: serial.unix.termios
|
||||
|
||||
{
|
||||
{ [ os linux? ] [ "serial.unix.termios.linux" ] }
|
||||
{ [ os bsd? ] [ "serial.unix.termios.bsd" ] }
|
||||
} cond require
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math.bitfields serial serial.unix ;
|
||||
IN: serial.unix
|
||||
|
||||
: serial-obj ( -- obj )
|
||||
serial new
|
||||
"/dev/ttyS0" >>path
|
||||
19200 >>baud
|
||||
{ IGNPAR ICRNL } flags >>iflag
|
||||
{ } flags >>oflag
|
||||
{ CS8 CLOCAL CREAD } flags >>cflag
|
||||
{ ICANON } flags >>lflag ;
|
||||
|
||||
: serial-test ( -- serial )
|
||||
serial-obj
|
||||
open-serial
|
||||
dup get-termios >>termios
|
||||
dup configure-termios
|
||||
dup tciflush
|
||||
dup apply-termios ;
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.syntax combinators io.ports
|
||||
io.streams.duplex io.unix.backend system kernel math math.bitfields
|
||||
vocabs.loader unix serial serial.unix.termios ;
|
||||
IN: serial.unix
|
||||
|
||||
<< {
|
||||
{ [ os linux? ] [ "serial.unix.linux" ] }
|
||||
{ [ os bsd? ] [ "serial.unix.bsd" ] }
|
||||
} cond require >>
|
||||
|
||||
FUNCTION: speed_t cfgetispeed ( termios* t ) ;
|
||||
FUNCTION: speed_t cfgetospeed ( termios* t ) ;
|
||||
FUNCTION: int cfsetispeed ( termios* t, speed_t s ) ;
|
||||
FUNCTION: int cfsetospeed ( termios* t, speed_t s ) ;
|
||||
FUNCTION: int tcgetattr ( int i1, termios* t ) ;
|
||||
FUNCTION: int tcsetattr ( int i1, int i2, termios* t ) ;
|
||||
FUNCTION: int tcdrain ( int i1 ) ;
|
||||
FUNCTION: int tcflow ( int i1, int i2 ) ;
|
||||
FUNCTION: int tcflush ( int i1, int i2 ) ;
|
||||
FUNCTION: int tcsendbreak ( int i1, int i2 ) ;
|
||||
FUNCTION: void cfmakeraw ( termios* t ) ;
|
||||
FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
|
||||
|
||||
: fd>duplex-stream ( fd -- duplex-stream )
|
||||
<fd> init-fd
|
||||
[ <input-port> ] [ <output-port> ] bi <duplex-stream> ;
|
||||
|
||||
: open-rw ( path -- fd ) O_RDWR file-mode open-file ;
|
||||
: <file-rw> ( path -- stream ) open-rw fd>duplex-stream ;
|
||||
|
||||
M: unix open-serial ( serial -- serial' )
|
||||
dup
|
||||
path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
|
||||
fd>duplex-stream >>stream ;
|
||||
|
||||
: serial-fd ( serial -- fd )
|
||||
stream>> in>> handle>> fd>> ;
|
||||
|
||||
: get-termios ( serial -- termios )
|
||||
serial-fd
|
||||
"termios" <c-object> [ tcgetattr io-error ] keep ;
|
||||
|
||||
: configure-termios ( serial -- )
|
||||
dup termios>>
|
||||
{
|
||||
[ [ iflag>> ] dip over [ set-termios-iflag ] [ 2drop ] if ]
|
||||
[ [ oflag>> ] dip over [ set-termios-oflag ] [ 2drop ] if ]
|
||||
[
|
||||
[
|
||||
[ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor
|
||||
] dip set-termios-cflag
|
||||
]
|
||||
[ [ lflag>> ] dip over [ set-termios-lflag ] [ 2drop ] if ]
|
||||
} 2cleave ;
|
||||
|
||||
: tciflush ( serial -- )
|
||||
serial-fd TCIFLUSH tcflush io-error ;
|
||||
|
||||
: apply-termios ( serial -- )
|
||||
[ serial-fd TCSANOW ]
|
||||
[ termios>> ] bi tcsetattr io-error ;
|
||||
Loading…
Reference in New Issue