From 8785b24e0493e45893f13b07ececc08b1a2f46fe Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 16:44:17 -0500 Subject: [PATCH 01/24] Now with arbitrary accuracy --- .../math/derivatives/derivatives-docs.factor | 50 +++++++++++- extra/math/derivatives/derivatives.factor | 80 +++++++++++++++++-- 2 files changed, 119 insertions(+), 11 deletions(-) diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index 23847e82f7..70389f18ad 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -3,7 +3,51 @@ USING: help.markup help.syntax ; 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: fast-derivative ( x function -- m ) +{ $values { "x" "a x-position on the function" } { "function" "a differentiable function" } } +{ $description + "Approximates the slope of the tangent line of the provided function " + "by using a secant line with very near points. This implementation is " + "naive and is only provided because it is used in the much more " + "accurate " { $link derivative } " word. Use this word if accuracy " + "is of no importance." +} ; + +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 ;" + "[ sq ] derivative-func ." + "[ [ sq ] derivative ]" + } +} ; + +ARTICLE: "derivatives" "The Derivative Toolkit" +"A toolkit for computing the derivative of functions." +{ $subsection derivative } +{ $subsection derivative-func } +{ $subsection fast-derivative } ; +ABOUT: "derivatives" diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index d92066efaf..f77748d0b5 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,10 +1,74 @@ -! 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 ; +! Copyright (c) 2008 Reginald Ford +! Tools for approximating derivatives + +USING: kernel math math.functions locals generalizations float-arrays sequences +math.constants namespaces math.function-tools math.points math.ranges math.order ; 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 ; \ No newline at end of file +! Ridders' method of a derivative, from the chapter +! "Accurate computation of F'(x) and F'(x)F''(x)", +! From "Advances in Engineering Software, Vol. 4, pp. 75-76 +! \ fast-derivative has been factored out for use by children + +: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable +: ntab 10 ; ! max size of tableau (main accuracy setting) +: con 1.41 ; ! stepsize is decreased by this per-iteration +: con2 1.9881 ; ! con^2 +: initial-h 0.02 ; ! distance of the 2 points of the first secant line +: safe 2.0 ; ! return when current err is SAFE worse than the best + ! \ safe probably should not be changed +SYMBOL: i +SYMBOL: j +SYMBOL: err +SYMBOL: errt +SYMBOL: fac +SYMBOL: h +SYMBOL: ans +SYMBOL: matrix + +: (derivative) ( x function -- m ) + [ [ h get + ] dip eval ] + [ [ h get - ] dip eval ] + 2bi slope ; inline +: fast-derivative ( x function -- m ) + over epsilon sqrt * h set + (derivative) ; inline +: init-matrix ( -- ) + ntab [ ntab ] replicate + matrix set ; +: m-set ( value j i -- ) matrix get nth set-nth ; +: m-get ( j i -- n ) matrix get nth nth ; +:: derivative ( x func -- m ) + init-matrix + initial-h h set + x func (derivative) 0 0 m-set + largest-float err set + ntab 1 - [1,b] [| i | + h [ con / ] change + x func (derivative) 0 i m-set + con2 fac set + i [1,b] [| j | + j 1 - i m-get fac get * + j 1 - i 1 - m-get + - + fac get 1 - + / j i m-set + fac [ con2 * ] change + j i m-get j 1 - i m-get - abs + j i m-get j 1 - i 1 - m-get - abs + max errt set + errt get err get <= + [ + errt get err set + j i m-get ans set + ] [ ] + if + ] each + i i m-get i 1 - dup m-get - abs + err get safe * + < + ] all? drop + ans get ; inline +: derivative-func ( function -- function ) [ derivative ] curry ; inline +: fast-derivative-func ( function -- function ) [ fast-derivative ] curry ; inline + From aee8dbdba45abf06eab2e974b2985bc4e9c41ed5 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 16:45:13 -0500 Subject: [PATCH 02/24] peer review by myself --- extra/24-game/24-game-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/24-game/24-game-docs.factor b/extra/24-game/24-game-docs.factor index 12a558b2d2..cd82f335d8 100644 --- a/extra/24-game/24-game-docs.factor +++ b/extra/24-game/24-game-docs.factor @@ -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 } "." } From 9d0acc555d51b1aba9918b8fd73269f6a5bd40cb Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 16:47:52 -0500 Subject: [PATCH 03/24] peer review by myself --- extra/animations/animations-docs.factor | 63 ++++++++++++++++++------- 1 file changed, 47 insertions(+), 16 deletions(-) diff --git a/extra/animations/animations-docs.factor b/extra/animations/animations-docs.factor index 6a1e89a28e..000c0ce4cc 100644 --- a/extra/animations/animations-docs.factor +++ b/extra/animations/animations-docs.factor @@ -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" \ No newline at end of file +! 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" \ No newline at end of file From 6ab0f6b09c633f6543b1feee16babefd8aab287a Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 16:48:54 -0500 Subject: [PATCH 04/24] No one else used middle name --- extra/animations/authors.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/animations/authors.txt b/extra/animations/authors.txt index dac0cb42fe..137b1605da 100644 --- a/extra/animations/authors.txt +++ b/extra/animations/authors.txt @@ -1 +1 @@ -Reginald Keith Ford II \ No newline at end of file +Reginald Ford \ No newline at end of file From a44097af93cebbef61d8bee80da94c93618b3b49 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 16:49:40 -0500 Subject: [PATCH 05/24] combinators should inline --- extra/math/function-tools/function-tools.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 802bf9e14e..ec93a0891a 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -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 From 6df077805d5a89972aa1679a78565645c3a525ad Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 18:20:14 -0500 Subject: [PATCH 06/24] minor fixes --- extra/math/derivatives/derivatives-docs.factor | 15 ++------------- extra/math/derivatives/derivatives.factor | 16 +++------------- 2 files changed, 5 insertions(+), 26 deletions(-) diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index 70389f18ad..0db52adfa5 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -17,20 +17,10 @@ HELP: derivative ( x function -- m ) } { $notes "For applied scientists, you may play with the settings " - "in the source file to achieve arbitrary accuracy." + "in the source file to achieve arbitrary accuracy. " } } ; -HELP: fast-derivative ( x function -- m ) -{ $values { "x" "a x-position on the function" } { "function" "a differentiable function" } } -{ $description - "Approximates the slope of the tangent line of the provided function " - "by using a secant line with very near points. This implementation is " - "naive and is only provided because it is used in the much more " - "accurate " { $link derivative } " word. Use this word if accuracy " - "is of no importance." -} ; - HELP: derivative-func ( function -- der ) { $values { "func" "a differentiable function" } { "der" "the derivative" } } { $description @@ -48,6 +38,5 @@ HELP: derivative-func ( function -- der ) ARTICLE: "derivatives" "The Derivative Toolkit" "A toolkit for computing the derivative of functions." { $subsection derivative } -{ $subsection derivative-func } -{ $subsection fast-derivative } ; +{ $subsection derivative-func } ; ABOUT: "derivatives" diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index f77748d0b5..96d0fc3a81 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,19 +1,13 @@ -! Copyright (c) 2008 Reginald Ford ! Tools for approximating derivatives USING: kernel math math.functions locals generalizations float-arrays sequences math.constants namespaces math.function-tools math.points math.ranges math.order ; IN: math.derivatives -! Ridders' method of a derivative, from the chapter -! "Accurate computation of F'(x) and F'(x)F''(x)", -! From "Advances in Engineering Software, Vol. 4, pp. 75-76 -! \ fast-derivative has been factored out for use by children - : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable -: ntab 10 ; ! max size of tableau (main accuracy setting) -: con 1.41 ; ! stepsize is decreased by this per-iteration -: con2 1.9881 ; ! con^2 +: ntab 10 ; ! max size of tableau (main accuracy setting) +: con 1.41 ; ! stepsize is decreased by this per-iteration +: con2 1.9881 ; ! con^2 : initial-h 0.02 ; ! distance of the 2 points of the first secant line : safe 2.0 ; ! return when current err is SAFE worse than the best ! \ safe probably should not be changed @@ -30,9 +24,6 @@ SYMBOL: matrix [ [ h get + ] dip eval ] [ [ h get - ] dip eval ] 2bi slope ; inline -: fast-derivative ( x function -- m ) - over epsilon sqrt * h set - (derivative) ; inline : init-matrix ( -- ) ntab [ ntab ] replicate matrix set ; @@ -70,5 +61,4 @@ SYMBOL: matrix ] all? drop ans get ; inline : derivative-func ( function -- function ) [ derivative ] curry ; inline -: fast-derivative-func ( function -- function ) [ fast-derivative ] curry ; inline From 6060b12ccb2d8e6a9ab4aafbe7d24e5e77cc75bf Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Sun, 10 Aug 2008 18:22:32 -0500 Subject: [PATCH 07/24] minor additions --- extra/animations/animations.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index 7efd618bbf..db5b3448c1 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -2,11 +2,14 @@ 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 ; : progress ( -- progress ) millis last-loop get - reset-progress ; : 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 ; \ No newline at end of file +: 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 \ No newline at end of file From bd168d06f258860a2d8c074d1e0335b02d6e1ec5 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 12 Aug 2008 00:28:22 -0400 Subject: [PATCH 08/24] now with progress-peek --- extra/animations/animations.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/animations/animations.factor b/extra/animations/animations.factor index db5b3448c1..803536a51c 100644 --- a/extra/animations/animations.factor +++ b/extra/animations/animations.factor @@ -8,7 +8,9 @@ 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 ; inline : animate ( quot duration -- ) reset-progress set-end loop ; inline From 759a939ecc713a331f6ea96fb4b0b6a1b4da060b Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 12 Aug 2008 02:58:12 -0300 Subject: [PATCH 09/24] irc.client: Refactorings --- extra/irc/client/client-tests.factor | 4 +- extra/irc/client/client.factor | 96 ++++++++++++------------ extra/irc/messages/messages-tests.factor | 4 +- extra/irc/messages/messages.factor | 5 ++ 4 files changed, 60 insertions(+), 49 deletions(-) diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor index 2b4b501952..932bdda472 100644 --- a/extra/irc/client/client-tests.factor +++ b/extra/irc/client/client-tests.factor @@ -49,10 +49,10 @@ M: mb-writer stream-nl ( mb-writer -- ) { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi" - parse-irc-line irc-message-origin ] unit-test + parse-irc-line forward-name ] unit-test { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi" - parse-irc-line irc-message-origin ] unit-test + parse-irc-line forward-name ] unit-test ] with-irc ! Test login and nickname set diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index e91767b22d..575c26972f 100644 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -3,7 +3,7 @@ USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar accessors destructors namespaces io assocs arrays qualified fry continuations threads strings classes combinators splitting hashtables - ascii irc.messages irc.messages.private ; + ascii irc.messages ; RENAME: join sequences => sjoin EXCLUDE: sequences => join ; IN: irc.client @@ -67,7 +67,6 @@ SINGLETON: irc-listener-end ! send to a listener to stop its execution SINGLETON: irc-end ! sent when the client isn't running anymore SINGLETON: irc-disconnected ! sent when connection is lost SINGLETON: irc-connected ! sent when connection is established -UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ; : terminate-irc ( irc-client -- ) [ is-running>> ] keep and [ @@ -122,6 +121,9 @@ M: irc-listener to-listener ( message irc-listener -- ) [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ] with filter ; +: to-listeners-with-participant ( message nickname -- ) + listeners-with-participant [ to-listener ] with each ; + : remove-participant-from-all ( nick -- ) dup listeners-with-participant [ (remove-participant) ] with each ; @@ -145,7 +147,7 @@ M: irc-listener to-listener ( message irc-listener -- ) DEFER: me? : maybe-forward-join ( join -- ) - [ prefix>> parse-name me? ] keep and + [ irc-message-sender me? ] keep and [ irc> join-messages>> mailbox-put ] when* ; ! ====================================== @@ -177,60 +179,64 @@ DEFER: me? : me? ( string -- ? ) irc> profile>> nickname>> = ; -: irc-message-origin ( irc-message -- name ) - dup name>> me? [ prefix>> parse-name ] [ name>> ] if ; +GENERIC: forward-name ( irc-message -- name ) +M: join forward-name ( join -- name ) trailing>> ; +M: part forward-name ( part -- name ) channel>> ; +M: kick forward-name ( kick -- name ) channel>> ; +M: mode forward-name ( mode -- name ) channel>> ; +M: privmsg forward-name ( privmsg -- name ) + dup name>> me? [ irc-message-sender ] [ name>> ] if ; -: broadcast-message-to-listeners ( message -- ) - irc> listeners>> values [ to-listener ] with each ; +UNION: single-forward join part kick mode privmsg ; +UNION: multiple-forward nick quit ; +UNION: broadcast-forward irc-end irc-disconnected irc-connected ; +GENERIC: forward-message ( irc-message -- ) -GENERIC: handle-incoming-irc ( irc-message -- ) - -M: irc-message handle-incoming-irc ( irc-message -- ) +M: irc-message forward-message ( irc-message -- ) +server-listener+ listener> [ to-listener ] [ drop ] if* ; -M: logged-in handle-incoming-irc ( logged-in -- ) +M: single-forward forward-message ( forward-single -- ) + dup forward-name to-listener ; + +M: multiple-forward forward-message ( multiple-forward -- ) + dup irc-message-sender to-listeners-with-participant ; + +M: join forward-message ( join -- ) + [ maybe-forward-join ] [ call-next-method ] bi ; + +M: broadcast-forward forward-message ( irc-broadcasted-message -- ) + irc> listeners>> values [ to-listener ] with each ; + +GENERIC: process-message ( irc-message -- ) + +M: object process-message ( object -- ) + drop ; + +M: logged-in process-message ( logged-in -- ) name>> irc> profile>> (>>nickname) ; -M: ping handle-incoming-irc ( ping -- ) +M: ping process-message ( ping -- ) trailing>> /PONG ; -M: nick-in-use handle-incoming-irc ( nick-in-use -- ) +M: nick-in-use process-message ( nick-in-use -- ) name>> "_" append /NICK ; -M: privmsg handle-incoming-irc ( privmsg -- ) - dup irc-message-origin to-listener ; +M: join process-message ( join -- ) + [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ; -M: join handle-incoming-irc ( join -- ) - [ maybe-forward-join ] - [ dup trailing>> to-listener ] - [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ] - tri ; +M: part process-message ( part -- ) + [ irc-message-sender ] [ channel>> ] bi remove-participant ; -M: part handle-incoming-irc ( part -- ) - [ dup channel>> to-listener ] - [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ] - bi ; - -M: kick handle-incoming-irc ( kick -- ) - [ dup channel>> to-listener ] +M: kick process-message ( kick -- ) [ [ who>> ] [ channel>> ] bi remove-participant ] [ dup who>> me? [ unregister-listener ] [ drop ] if ] - tri ; - -M: quit handle-incoming-irc ( quit -- ) - [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ prefix>> parse-name remove-participant-from-all ] bi ; -M: mode handle-incoming-irc ( mode -- ) ! FIXME: modify participant list - dup channel>> to-listener ; +M: quit process-message ( quit -- ) + irc-message-sender remove-participant-from-all ; -M: nick handle-incoming-irc ( nick -- ) - [ dup prefix>> parse-name listeners-with-participant - [ to-listener ] with each ] - [ [ prefix>> parse-name ] [ trailing>> ] bi rename-participant-in-all ] - bi ; +M: nick process-message ( nick -- ) + [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ; : >nick/mode ( string -- nick mode ) dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ; @@ -239,22 +245,20 @@ M: nick handle-incoming-irc ( nick -- ) trailing>> [ blank? ] trim " " split [ >nick/mode 2array ] map >hashtable ; -M: names-reply handle-incoming-irc ( names-reply -- ) +M: names-reply process-message ( names-reply -- ) [ names-reply>participants ] [ channel>> listener> ] bi [ [ (>>participants) ] [ [ f f f ] dip name>> to-listener ] bi ] [ drop ] if* ; -M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- ) - broadcast-message-to-listeners ; +: handle-incoming-irc ( irc-message -- ) + [ forward-message ] [ process-message ] bi ; ! ====================================== ! Client message handling ! ====================================== -GENERIC: handle-outgoing-irc ( obj -- ) - -M: irc-message handle-outgoing-irc ( irc-message -- ) +: handle-outgoing-irc ( irc-message -- ) irc-message>client-line irc-print ; ! ====================================== diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 7ee0f41ab0..20f4f1b277 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -3,7 +3,9 @@ USING: kernel tools.test accessors arrays qualified EXCLUDE: sequences => join ; IN: irc.messages.tests -! Parsing tests + +{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test + irc-message new ":someuser!n=user@some.where PRIVMSG #factortest :hi" >>line "someuser!n=user@some.where" >>prefix diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 3b9cf0af2c..64fa9fc2c2 100644 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -98,6 +98,11 @@ M: irc-message irc-message>server-line ( irc-message -- string ) PRIVATE> +UNION: sender-in-prefix privmsg join part quit kick mode nick ; +GENERIC: irc-message-sender ( irc-message -- sender ) +M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender ) + prefix>> parse-name ; + : string>irc-message ( string -- object ) dup split-prefix split-trailing [ [ blank? ] trim " " split unclip swap ] dip From 2271aae7f070b5c373547f122d07861d239e74d1 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 12 Aug 2008 02:42:23 -0400 Subject: [PATCH 10/24] compatible with demos menu --- extra/24-game/24-game.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 52f0cd6833..126215ab13 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -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 ; \ No newline at end of file +: play-game ( -- ) set-commands 24-able repeat ; +MAIN: play-game \ No newline at end of file From 359bff5f154caaaaa9ed5037e78d43033cdf48b3 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 12 Aug 2008 11:24:00 -0400 Subject: [PATCH 11/24] Derivatives without dynamics OR locals --- extra/math/derivatives/authors.txt | 3 +- .../math/derivatives/derivatives-docs.factor | 66 ++++++- extra/math/derivatives/derivatives.factor | 175 ++++++++++++------ 3 files changed, 181 insertions(+), 63 deletions(-) diff --git a/extra/math/derivatives/authors.txt b/extra/math/derivatives/authors.txt index 137b1605da..3be8a6d4d3 100644 --- a/extra/math/derivatives/authors.txt +++ b/extra/math/derivatives/authors.txt @@ -1 +1,2 @@ -Reginald Ford \ No newline at end of file +Reginald Ford +Eduardo Cavazos \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index 0db52adfa5..a78a697b76 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax ; - +USING: help.markup help.syntax math.functions ; IN: math.derivatives HELP: derivative ( x function -- m ) @@ -21,6 +20,46 @@ HELP: derivative ( x function -- m ) } } ; +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 @@ -30,8 +69,27 @@ HELP: derivative-func ( function -- der ) { $examples { $example "USING: math.derivatives prettyprint ;" - "[ sq ] derivative-func ." - "[ [ sq ] derivative ]" + "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" + + } } } ; diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index 96d0fc3a81..ad8d944bfe 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,64 +1,123 @@ -! Tools for approximating derivatives -USING: kernel math math.functions locals generalizations float-arrays sequences -math.constants namespaces math.function-tools math.points math.ranges math.order ; +USING: kernel continuations combinators sequences math + math.order math.ranges accessors float-arrays ; + IN: math.derivatives +TUPLE: state x func h err i j errt fac hh ans a done ; + : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable -: ntab 10 ; ! max size of tableau (main accuracy setting) -: con 1.41 ; ! stepsize is decreased by this per-iteration -: con2 1.9881 ; ! con^2 -: initial-h 0.02 ; ! distance of the 2 points of the first secant line -: safe 2.0 ; ! return when current err is SAFE worse than the best - ! \ safe probably should not be changed -SYMBOL: i -SYMBOL: j -SYMBOL: err -SYMBOL: errt -SYMBOL: fac -SYMBOL: h -SYMBOL: ans -SYMBOL: matrix +: ntab ( -- val ) 8 ; +: con ( -- val ) 1.6 ; +: con2 ( -- val ) con con * ; +: big ( -- val ) largest-float ; +: safe ( -- val ) 2.0 ; -: (derivative) ( x function -- m ) - [ [ h get + ] dip eval ] - [ [ h get - ] dip eval ] - 2bi slope ; inline -: init-matrix ( -- ) - ntab [ ntab ] replicate - matrix set ; -: m-set ( value j i -- ) matrix get nth set-nth ; -: m-get ( j i -- n ) matrix get nth nth ; -:: derivative ( x func -- m ) - init-matrix - initial-h h set - x func (derivative) 0 0 m-set - largest-float err set - ntab 1 - [1,b] [| i | - h [ con / ] change - x func (derivative) 0 i m-set - con2 fac set - i [1,b] [| j | - j 1 - i m-get fac get * - j 1 - i 1 - m-get - - - fac get 1 - - / j i m-set - fac [ con2 * ] change - j i m-get j 1 - i m-get - abs - j i m-get j 1 - i 1 - m-get - abs - max errt set - errt get err get <= - [ - errt get err set - j i m-get ans set - ] [ ] - if - ] each - i i m-get i 1 - dup m-get - abs - err get safe * - < - ] all? drop - ans get ; inline -: derivative-func ( function -- function ) [ derivative ] curry ; inline +! 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 ] 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 ; \ No newline at end of file From 6f767add2c4fada948553e2639888a6539d7ae1c Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 12 Aug 2008 12:00:54 -0400 Subject: [PATCH 12/24] documentation for scientists --- extra/math/derivatives/derivatives-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor index a78a697b76..15dd954b1c 100644 --- a/extra/math/derivatives/derivatives-docs.factor +++ b/extra/math/derivatives/derivatives-docs.factor @@ -96,5 +96,6 @@ HELP: derivative-func ( function -- der ) ARTICLE: "derivatives" "The Derivative Toolkit" "A toolkit for computing the derivative of functions." { $subsection derivative } -{ $subsection derivative-func } ; +{ $subsection derivative-func } +{ $subsection (derivative) } ; ABOUT: "derivatives" From 8b3ce1ee841c78832671726066588d075226e008 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 13 Aug 2008 01:00:26 -0400 Subject: [PATCH 13/24] irc:Added whois command, fixed bug in parting --- extra/irc/messages/messages.factor | 2 +- extra/irc/ui/commands/commands.factor | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/irc/messages/messages.factor diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor old mode 100644 new mode 100755 index 3b9cf0af2c..fb56dd3a45 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -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 ; diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index ddae783f06..184a2b4de8 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -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-tab get listener>> write-message ; + : quote ( string -- ) drop ; ! THIS WILL CHANGE From bbb3597ac2a45207d33455f4cc165607d859f25e Mon Sep 17 00:00:00 2001 From: sheeple Date: Wed, 13 Aug 2008 15:13:55 -0500 Subject: [PATCH 14/24] add a couple constants for unix file access --- basis/unix/bsd/bsd.factor | 17 +++++++++-------- basis/unix/linux/linux.factor | 17 +++++++++-------- basis/unix/unix.factor | 2 ++ 3 files changed, 20 insertions(+), 16 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 0c669d2258..68444de85f 100755 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -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" } diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 0efacee294..cc1e056b8b 100755 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -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" } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 083700493d..065087fa59 100755 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -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" } From 21fb13f4504aa5e8070c19d9a18c4b904f0135b9 Mon Sep 17 00:00:00 2001 From: sheeple Date: Wed, 13 Aug 2008 15:18:50 -0500 Subject: [PATCH 15/24] initial chicken of serial --- extra/serial/authors.txt | 1 + extra/serial/serial.factor | 23 ++++ extra/serial/summary.txt | 1 + extra/serial/tags.txt | 1 + extra/serial/unix/bsd/bsd.factor | 11 ++ extra/serial/unix/bsd/tags.txt | 1 + extra/serial/unix/linux/linux.factor | 130 +++++++++++++++++++ extra/serial/unix/linux/tags.txt | 1 + extra/serial/unix/tags.txt | 1 + extra/serial/unix/termios/bsd/bsd.factor | 19 +++ extra/serial/unix/termios/bsd/tags.txt | 1 + extra/serial/unix/termios/linux/linux.factor | 20 +++ extra/serial/unix/termios/linux/tags.txt | 1 + extra/serial/unix/termios/tags.txt | 1 + extra/serial/unix/termios/termios.factor | 9 ++ extra/serial/unix/unix-tests.factor | 21 +++ extra/serial/unix/unix.factor | 63 +++++++++ 17 files changed, 305 insertions(+) create mode 100644 extra/serial/authors.txt create mode 100644 extra/serial/serial.factor create mode 100644 extra/serial/summary.txt create mode 100644 extra/serial/tags.txt create mode 100644 extra/serial/unix/bsd/bsd.factor create mode 100644 extra/serial/unix/bsd/tags.txt create mode 100644 extra/serial/unix/linux/linux.factor create mode 100644 extra/serial/unix/linux/tags.txt create mode 100644 extra/serial/unix/tags.txt create mode 100644 extra/serial/unix/termios/bsd/bsd.factor create mode 100644 extra/serial/unix/termios/bsd/tags.txt create mode 100644 extra/serial/unix/termios/linux/linux.factor create mode 100644 extra/serial/unix/termios/linux/tags.txt create mode 100644 extra/serial/unix/termios/tags.txt create mode 100644 extra/serial/unix/termios/termios.factor create mode 100644 extra/serial/unix/unix-tests.factor create mode 100644 extra/serial/unix/unix.factor diff --git a/extra/serial/authors.txt b/extra/serial/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/serial/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/serial/serial.factor b/extra/serial/serial.factor new file mode 100644 index 0000000000..39a63927da --- /dev/null +++ b/extra/serial/serial.factor @@ -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 diff --git a/extra/serial/summary.txt b/extra/serial/summary.txt new file mode 100644 index 0000000000..5ccd99dbaa --- /dev/null +++ b/extra/serial/summary.txt @@ -0,0 +1 @@ +Serial port library diff --git a/extra/serial/tags.txt b/extra/serial/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor new file mode 100644 index 0000000000..68aaa03a23 --- /dev/null +++ b/extra/serial/unix/bsd/bsd.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel 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 ; diff --git a/extra/serial/unix/bsd/tags.txt b/extra/serial/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/linux/linux.factor b/extra/serial/unix/linux/linux.factor new file mode 100644 index 0000000000..3ad5088fc8 --- /dev/null +++ b/extra/serial/unix/linux/linux.factor @@ -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 ; diff --git a/extra/serial/unix/linux/tags.txt b/extra/serial/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/tags.txt b/extra/serial/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/bsd/bsd.factor b/extra/serial/unix/termios/bsd/bsd.factor new file mode 100644 index 0000000000..c8f1e8be54 --- /dev/null +++ b/extra/serial/unix/termios/bsd/bsd.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: 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 diff --git a/extra/serial/unix/termios/bsd/tags.txt b/extra/serial/unix/termios/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/linux/linux.factor b/extra/serial/unix/termios/linux/linux.factor new file mode 100644 index 0000000000..de9906e2b9 --- /dev/null +++ b/extra/serial/unix/termios/linux/linux.factor @@ -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 diff --git a/extra/serial/unix/termios/linux/tags.txt b/extra/serial/unix/termios/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/tags.txt b/extra/serial/unix/termios/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/serial/unix/termios/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/serial/unix/termios/termios.factor b/extra/serial/unix/termios/termios.factor new file mode 100644 index 0000000000..901416d62c --- /dev/null +++ b/extra/serial/unix/termios/termios.factor @@ -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 diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor new file mode 100644 index 0000000000..300cacf83e --- /dev/null +++ b/extra/serial/unix/unix-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math.bitfields 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 ; diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor new file mode 100644 index 0000000000..6b48c758cc --- /dev/null +++ b/extra/serial/unix/unix.factor @@ -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 ) + init-fd + [ ] [ ] bi ; + +: open-rw ( path -- fd ) O_RDWR file-mode open-file ; +: ( 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" [ 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 ; From ca27c897d092b4b4d5d80c73ea24fb0f635a27b6 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 13 Aug 2008 20:52:30 -0400 Subject: [PATCH 16/24] irc.ui: Removed reference to irc.messages.private --- extra/irc/ui/ui.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 4757e36660..f144674ce9 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -8,7 +8,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels io io.styles namespaces calendar calendar.format models continuations - irc.client irc.client.private irc.messages irc.messages.private + irc.client irc.client.private irc.messages irc.ui.commandparser irc.ui.load ; RENAME: join sequences => sjoin @@ -39,7 +39,7 @@ M: ping write-irc M: privmsg write-irc "<" blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep "> " blue write-color trailing>> write ; @@ -61,24 +61,24 @@ M: own-message write-irc M: join write-irc "* " dark-green write-color - prefix>> parse-name write + irc-message-sender write " has entered the channel." dark-green write-color ; M: part write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left the channel" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: quit write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has left IRC" dark-red write-color trailing>> dot-or-parens dark-red write-color ; M: kick write-irc "* " dark-red write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has kicked " dark-red write-color [ who>> write ] keep " from the channel" dark-red write-color @@ -89,7 +89,7 @@ M: kick write-irc M: mode write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " has applied mode " blue write-color [ full-mode write ] keep " to " blue write-color @@ -97,7 +97,7 @@ M: mode write-irc M: nick write-irc "* " blue write-color - [ prefix>> parse-name write ] keep + [ irc-message-sender write ] keep " is now known as " blue write-color trailing>> write ; From 83574cb5ee01c152e58f0873ca568092c70b76cc Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Wed, 13 Aug 2008 20:58:05 -0400 Subject: [PATCH 17/24] irc.ui: Removed userlist slot from irc-tab --- extra/irc/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index f144674ce9..956644dc52 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -21,7 +21,7 @@ SYMBOL: client TUPLE: ui-window < tabbed client ; -TUPLE: irc-tab < frame listener client window userlist ; +TUPLE: irc-tab < frame listener client window ; : write-color ( str color -- ) foreground associate format ; From c5e3bdf66842e54e3a791eb2f28d3d0eb6832956 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 Aug 2008 21:51:25 -0500 Subject: [PATCH 18/24] add constants for bsd serial --- extra/serial/unix/bsd/bsd.factor | 15 ++++++++++++++- extra/serial/unix/termios/bsd/bsd.factor | 2 +- extra/serial/unix/unix.factor | 4 ++-- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor index 68aaa03a23..7dac47193a 100644 --- a/extra/serial/unix/bsd/bsd.factor +++ b/extra/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences system serial ; +USING: alien.syntax kernel sequences system serial ; IN: serial.unix M: bsd lookup-baud ( m -- n ) @@ -9,3 +9,16 @@ M: bsd lookup-baud ( m -- n ) 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 diff --git a/extra/serial/unix/termios/bsd/bsd.factor b/extra/serial/unix/termios/bsd/bsd.factor index c8f1e8be54..5fbc571519 100644 --- a/extra/serial/unix/termios/bsd/bsd.factor +++ b/extra/serial/unix/termios/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences system ; +USING: alien.syntax kernel sequences system ; IN: serial.unix.termios : NCCS 20 ; inline diff --git a/extra/serial/unix/unix.factor b/extra/serial/unix/unix.factor index 6b48c758cc..7ed5bced37 100644 --- a/extra/serial/unix/unix.factor +++ b/extra/serial/unix/unix.factor @@ -5,10 +5,10 @@ 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 +} cond require >> FUNCTION: speed_t cfgetispeed ( termios* t ) ; FUNCTION: speed_t cfgetospeed ( termios* t ) ; From f98729eb91d6fe6187edd8fadd5f53915c03e18a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 Aug 2008 22:04:12 -0500 Subject: [PATCH 19/24] more bsd flags --- extra/serial/unix/bsd/bsd.factor | 64 ++++++++++++++++++++++++++++- extra/serial/unix/unix-tests.factor | 2 +- 2 files changed, 64 insertions(+), 2 deletions(-) diff --git a/extra/serial/unix/bsd/bsd.factor b/extra/serial/unix/bsd/bsd.factor index 7dac47193a..feed85348b 100644 --- a/extra/serial/unix/bsd/bsd.factor +++ b/extra/serial/unix/bsd/bsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences system serial ; +USING: alien.syntax kernel math.bitfields sequences system serial ; IN: serial.unix M: bsd lookup-baud ( m -- n ) @@ -22,3 +22,65 @@ M: bsd lookup-baud ( m -- n ) : 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 diff --git a/extra/serial/unix/unix-tests.factor b/extra/serial/unix/unix-tests.factor index 300cacf83e..bab6c3f4f1 100644 --- a/extra/serial/unix/unix-tests.factor +++ b/extra/serial/unix/unix-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.bitfields serial.unix ; +USING: accessors kernel math.bitfields serial serial.unix ; IN: serial.unix : serial-obj ( -- obj ) From 805cb650bd889221009b5841d6298fed8dee49c1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 Aug 2008 23:09:43 -0500 Subject: [PATCH 20/24] add find-hrefs word --- extra/html/parser/analyzer/analyzer.factor | 6 ++++++ extra/html/parser/parser.factor | 10 ++++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index dca727b9dc..f167feba06 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -140,6 +140,12 @@ TUPLE: link attributes clickable ; : href-contains? ( str tag -- ? ) attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; +: find-hrefs ( vector -- vector' ) + find-links + [ [ + [ name>> "a" = ] + [ attributes>> "href" swap key? ] bi and ] filter + ] map sift [ [ attributes>> "href" swap at ] map ] map concat ; : find-forms ( vector -- vector' ) "form" over find-opening-tags-by-name diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index c8aa9aa9e6..dbf6c52a0d 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,4 +1,4 @@ -USING: arrays html.parser.utils hashtables io kernel +USING: accessors arrays html.parser.utils hashtables io kernel namespaces prettyprint quotations sequences splitting state-parser strings unicode.categories unicode.case ; IN: html.parser @@ -23,8 +23,10 @@ SYMBOL: tagstack ] if ; : ( name attributes closing? -- tag ) - { set-tag-name set-tag-attributes set-tag-closing? } - tag construct ; + tag new + swap >>closing? + swap >>attributes + swap >>name ; : make-tag ( str attribs -- tag ) >r [ closing-tag? ] keep "/" trim1 r> rot ; @@ -75,7 +77,7 @@ SYMBOL: tagstack read-quote ] [ read-token - ] if ; + ] if [ blank? ] trim ; : read-comment ( -- ) "-->" take-string* make-comment-tag push-tag ; From d50afc2a35317618b1b3c5ca70b863edef3d6304 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 Aug 2008 23:13:13 -0500 Subject: [PATCH 21/24] remove unfinished code for now --- extra/html/parser/printer/printer.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor index d352a97688..27cb21a927 100644 --- a/extra/html/parser/printer/printer.factor +++ b/extra/html/parser/printer/printer.factor @@ -83,13 +83,6 @@ M: src-printer print-closing-named-tag ( tag -- ) SYMBOL: tab-width SYMBOL: #indentations -: html-pp ( vector -- ) - [ - 0 #indentations set - 2 tab-width set - - ] with-scope ; - : print-tabs ( -- ) tab-width get #indentations get * CHAR: \s write ; @@ -125,3 +118,6 @@ M: printer print-tag ( tag -- ) ! H{ { table-gap { 10 10 } } } [ ! [ [ [ [ . ] with-cell ] each ] with-row ] each ! ] tabular-output + +! : html-pp ( vector -- ) + ! [ 0 #indentations set 2 tab-width set ] with-scope ; From d9074c9d4e0c5ba7b634c5d5e5dee13cfa447554 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 13 Aug 2008 23:20:44 -0500 Subject: [PATCH 22/24] fix bootstrap --- basis/unix/bsd/bsd.factor | 1 + basis/unix/linux/linux.factor | 1 + basis/unix/unix.factor | 3 --- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 68444de85f..6934d5b8dc 100755 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -16,6 +16,7 @@ IN: unix : O_TRUNC HEX: 0400 ; inline : O_EXCL HEX: 0800 ; inline : O_NOCTTY HEX: 20000 ; inline +: O_NDELAY O_NONBLOCK ; inline : SOL_SOCKET HEX: ffff ; inline : SO_REUSEADDR HEX: 4 ; inline diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index cc1e056b8b..0c08cf0f2b 100755 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -16,6 +16,7 @@ USING: alien.syntax ; : O_TRUNC HEX: 0200 ; inline : O_APPEND HEX: 0400 ; inline : O_NONBLOCK HEX: 0800 ; inline +: O_NDELAY O_NONBLOCK ; inline : SOL_SOCKET 1 ; inline diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 065087fa59..4ae74f8267 100755 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -25,8 +25,6 @@ TYPEDEF: uint socklen_t : NGROUPS_MAX 16 ; inline -: O_NDELAY O_NONBLOCK ; inline - C-STRUCT: group { "char*" "gr_name" } { "char*" "gr_passwd" } @@ -194,4 +192,3 @@ FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { [ os bsd? ] [ "unix.bsd" require ] } { [ os solaris? ] [ "unix.solaris" require ] } } cond - From 2186999fee2a7c66f79ba7cab9a5e2eba16d35a6 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Thu, 14 Aug 2008 00:52:29 -0400 Subject: [PATCH 23/24] irc.ui: Fixed userlist>> bug --- extra/irc/ui/ui.factor | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 956644dc52..5d74c884c4 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -21,6 +21,9 @@ SYMBOL: client TUPLE: ui-window < tabbed client ; +M: ui-window ungraft* + client>> terminate-irc ; + TUPLE: irc-tab < frame listener client window ; : write-color ( str color -- ) @@ -139,16 +142,6 @@ GENERIC: handle-inbox ( tab message -- ) : add-gadget-color ( pack seq color -- pack ) '[ , >>color add-gadget ] each ; -: update-participants ( tab -- ) - [ userlist>> [ clear-gadget ] keep ] - [ listener>> participants>> ] bi - [ +operator+ value-labels dark-green add-gadget-color ] - [ +voice+ value-labels blue add-gadget-color ] - [ +normal+ value-labels black add-gadget-color ] tri drop ; - -M: participant-changed handle-inbox - drop update-participants ; - M: object handle-inbox nip print-irc ; @@ -198,15 +191,21 @@ TUPLE: irc-channel-tab < irc-tab userlist ; irc-tab new-irc-tab [ @right grid-add ] keep >>userlist ; +: update-participants ( tab -- ) + [ userlist>> [ clear-gadget ] keep ] + [ listener>> participants>> ] bi + [ +operator+ value-labels dark-green add-gadget-color ] + [ +voice+ value-labels blue add-gadget-color ] + [ +normal+ value-labels black add-gadget-color ] tri drop ; + +M: participant-changed handle-inbox + drop update-participants ; + TUPLE: irc-server-tab < irc-tab ; : ( listener -- irc-tab ) f irc-server-tab new-irc-tab ; -M: irc-server-tab ungraft* - [ window>> client>> terminate-irc ] - [ listener>> ] [ window>> client>> ] tri remove-listener ; - : ( listener ui-window -- irc-tab ) irc-tab new-irc-tab ; From a84404bc0d2937baf143169ef59b08ff099e6444 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 Aug 2008 00:21:10 -0500 Subject: [PATCH 24/24] add some more utility words like when-empty --- extra/sequences/lib/lib.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1167a3b7b4..17f855c264 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -211,8 +211,11 @@ PRIVATE> : insert-nth ( elt n seq -- seq' ) swap cut-slice [ swap 1array ] dip 3append ; -: if-seq ( seq quot1 quot2 -- ) - [ f like ] 2dip if* ; inline +: if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline + +: if-empty ( seq quot1 quot2 -- ) swap if-seq ; inline + +: when-empty ( seq quot1 -- ) [ ] if-empty ; inline + +: unless-empty ( seq quot1 -- ) [ ] swap if-empty ; inline -: if-empty ( seq quot1 quot2 -- ) - swap if-seq ; inline