From f19889b40547119696172fab836bf1e4735bdd12 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 14 Jul 2006 10:58:24 +0000 Subject: [PATCH] Remove infix since it no longer works and there's no interest in updating it --- contrib/README.txt | 2 +- contrib/math/infix.factor | 365 -------------------------------------- 2 files changed, 1 insertion(+), 366 deletions(-) delete mode 100644 contrib/math/infix.factor diff --git a/contrib/README.txt b/contrib/README.txt index d00a473964..b1dbed5b70 100644 --- a/contrib/README.txt +++ b/contrib/README.txt @@ -18,7 +18,7 @@ Credits: - factory -- X11 window manager (Eduardo Cavazos) - gap-buffer -- Efficient text editor buffer (Alex Chapman) - httpd -- Web framework (HTTP server, client, XML parser, HTML generation...) (Slava Pestov, Chris Double, Daniel Ehrenberg) -- math -- extended math library (Doug Coleman, Daniel Ehrenberg, Slava Pestov) +- math -- extended math library (Doug Coleman, Slava Pestov) - parser-combinators -- Lazy lists and Haskell-style parser combinators (Chris Double) - postgresql -- PostgreSQL binding (Doug Coleman) - process -- Run external programs (Slava Pestov) diff --git a/contrib/math/infix.factor b/contrib/math/infix.factor deleted file mode 100644 index f0c8e1df70..0000000000 --- a/contrib/math/infix.factor +++ /dev/null @@ -1,365 +0,0 @@ -IN: infix -USING: arrays errors generic hashtables io kernel kernel-internals lists math math-contrib namespaces parser parser-combinators prettyprint sequences strings vectors words ; - -: 2list ( x y -- [ x y ] ) f cons cons ; - -! Tokenizer - -TUPLE: tok char ; - -TUPLE: brackets seq ender ; - -SYMBOL: apostrophe - -SYMBOL: code #! Source code -SYMBOL: spot #! Current index of string - -: take-until ( quot -- parsed-stuff | quot: char -- ? ) - #! Take the substring of a string starting at spot - #! from code until the quotation given is true and - #! advance spot to after the substring. - >r spot get code get 2dup r> - skip [ swap subseq ] keep - spot set ; - -: parse-blank ( -- ) - #! Advance code past any whitespace, including newlines - spot get code get [ blank? not ] skip spot set ; - -: not-done? ( -- ? ) - #! Return t if spot is not at the end of code - code get length spot get = not ; - -: incr-spot ( -- ) - #! Increment spot. - spot [ 1 + ] change ; - -: parse-var ( -- variable-name ) - #! Take a series of letters from code, advancing - #! spot and returning the letters. - [ letter? not ] take-until ; - -: parse-num ( -- number ) - #! Take a number from code, advancing spot and - #! returning the number. - [ "0123456789." member? not ] take-until string>number ; - -: get-token ( -- char ) - spot get code get nth ; - -DEFER: token - -: next-token ( list -- list ) - #! Take one token from code and return it - parse-blank not-done? [ - get-token token - ] when ; - -: token - { - { [ dup letter? ] [ drop parse-var swons ] } - { [ dup "0123456789." member? ] [ drop parse-num swons ] } - { [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ swons incr-spot ] } - { [ dup "([{" member? ] [ drop f incr-spot ] } - { [ dup ")]}" member? ] [ swons incr-spot ] } - { [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] } - { [ t ] [ "Bad character " swap ch>string append throw ] } - } cond next-token ; - -: tokenize ( string -- tokens ) - #! Tokenize a string, returning a list of tokens - [ - code set 0 spot set - f next-token reverse - ] with-scope ; - - -! Parser - -TUPLE: apply func args ; - #! Function application -C: apply - >r [ ] subset r> - [ set-apply-args ] keep - [ set-apply-func ] keep ; - -UNION: value number string ; - -: semicolon ( -- semicolon ) - #! The semicolon token - T{ tok f CHAR: ; } ; - -: unswons uncons swap ; - -: nest-apply ( [ ast ] -- apply ) - unswons unit swap [ - swap unit - ] each car ; - -GENERIC: parse-token ( ast tokens token -- ast tokens ) - #! Take one or more tokens - -DEFER: parse-tokens - -: semicolon-split ( list -- [ ast ] ) - reverse semicolon unit split [ parse-tokens ] map ; - -M: value parse-token - swapd swons swap ; - -M: brackets parse-token - swapd dup brackets-seq swap brackets-ender { - { [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> swons ] } - { [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] } - { [ CHAR: ) = ] [ reverse parse-tokens swons ] } - } cond swap ; - -M: object tok-char drop -1 ; ! Hack! - -GENERIC: tok>string ( token/string -- string ) -M: tok tok>string - tok-char ch>string ; -M: string tok>string ; - -: binary-op ( ast tokens token -- ast ) - >r >r unswons r> parse-tokens 2list r> - tok>string swap swons ; - -: unary-op ( ast tokens token -- ast ) - tok>string -rot nip - parse-tokens unit unit ; - -: null-op ( ast tokens token -- ast ) - nip tok-char ch>string swons ; - -M: tok parse-token - over [ - pick [ - binary-op - ] [ - unary-op - ] if - ] [ - null-op - ] if f ; - -( ast tokens token -- ast tokens ) - -M: symbol parse-token ! apostrophe - drop unswons >r parse-tokens >r unswons r> 2list r> - unit parse-tokens swap swons f ; - -: (parse-tokens) ( ast tokens -- ast ) - dup [ - unswons parse-token (parse-tokens) - ] [ - drop - ] if ; - -: parse-tokens ( tokens -- ast ) - #! Convert a list of tokens into an AST - f swap (parse-tokens) nest-apply ; - -: parse-full ( string -- ast ) - #! Convert a string into an AST - tokenize parse-tokens ; - - -! Compiler - -GENERIC: compile-ast ( vars ast -- quot ) - -M: string compile-ast ! variables - swap index dup -1 = [ - "Variable not found" throw - ] [ - [ swap array-nth ] cons - ] if ; - -: replace-with ( data -- [ drop data ] ) - \ drop swap 2list ; - -UNION: comp-literal number general-list ; - -M: comp-literal compile-ast ! literal numbers - replace-with nip ; - -: accumulator ( vars { asts } quot -- quot ) - -rot [ - [ - \ dup , - compile-ast % - dup % - ] each-with - ] [ ] make nip ; - -M: vector compile-ast ! literal vectors - dup [ number? ] all? [ - replace-with nip - ] [ - [ , ] accumulator [ { } make nip ] cons - ] if ; - -: infix-relation - #! Wraps operators like = and > so that if they're given - #! f as either argument, they return f, and they return f if - #! the operation yields f, but if it yields t, it returns the - #! left argument. This way, these types of operations can be - #! composed. - >r 2dup and not [ - r> 3drop f - ] [ - dupd r> call [ - drop f - ] unless - ] if ; - -: functions - #! Regular functions - #! Gives quotation applicable to stack - H{ - [ [[ "+" 2 ]] + ] - [ [[ "-" 2 ]] - ] - [ [[ ">" 2 ]] [ > ] infix-relation ] - [ [[ "<" 2 ]] [ < ] infix-relation ] - [ [[ "=" 2 ]] [ = ] infix-relation ] - [ [[ "-" 1 ]] neg ] - [ [[ "~" 1 ]] not ] - [ [[ "&" 2 ]] and ] - [ [[ "|" 2 ]] or ] - [ [[ "&" 1 ]] t [ and ] reduce ] - [ [[ "|" 1 ]] f [ or ] reduce ] - [ [[ "*" 2 ]] * ] - [ [[ "ln" 1 ]] log ] - [ [[ "plusmin" 2 ]] [ + ] 2keep - ] - [ [[ "@" 2 ]] swap nth ] - [ [[ "sqrt" 1 ]] sqrt ] - [ [[ "/" 2 ]] / ] - [ [[ "^" 2 ]] ^ ] - [ [[ "#" 1 ]] length ] - [ [[ "eq" 2 ]] eq? ] - [ [[ "*" 1 ]] first ] - [ [[ "+" 1 ]] flip ] - [ [[ "\\" 1 ]] ] - [ [[ "sin" 1 ]] sin ] - [ [[ "cos" 1 ]] cos ] - [ [[ "tan" 1 ]] tan ] - [ [[ "max" 2 ]] max ] - [ [[ "min" 2 ]] min ] - [ [[ "," 2 ]] append ] - [ [[ "," 1 ]] concat ] - [ [[ "sn" 3 ]] -rot set-nth ] - [ [[ "prod" 1 ]] product ] - [ [[ "vec" 1 ]] >vector ] - } ; - -: drc ( list -- list ) - #! all of list except last element (backwards cdr) - dup cdr [ - uncons drc cons - ] [ - drop f - ] if ; - -: map-with-left ( seq object quot -- seq ) - [ swapd call ] cons swapd map-with ; inline - -: high-functions - #! Higher-order functions - #! Gives quotation applicable to quotation and rest of stack - H{ - [ [[ "!" 2 ]] 2map ] - [ [[ "!" 1 ]] map ] - [ [[ ">" 2 ]] map-with ] - [ [[ "<" 2 ]] map-with-left ] - [ [[ "^" 1 ]] all? ] - [ [[ "~" 1 ]] call not ] - [ [[ "~" 2 ]] call not ] - [ [[ "/" 2 ]] swapd reduce ] - [ [[ "\\" 2 ]] swapd accumulate ] - } ; - -: get-hash ( key table -- value ) - #! like hash but throws exception if f - dupd hash [ nip ] [ - [ "Key not found " write . ] string-out throw - ] if* ; - -: >apply< ( apply -- func args ) - dup apply-func swap apply-args ; - -: make-apply ( arity apply/string -- quot ) - dup string? [ - swons functions get-hash - ] [ - >apply< car >r over r> make-apply - -rot swons high-functions get-hash cons - ] if ; - -: get-function ( apply -- quot ) - >apply< length swap make-apply ; - -M: apply compile-ast ! function application - [ apply-args [ swap ] accumulator [ drop ] append ] keep - get-function append ; - -: push-list ( list item -- list ) - unit append ; - -: parse-comp ( args string -- quot ) - #! Compile a string into a quotation w/o prologue - parse-full compile-ast ; - -: prologue ( args -- quot ) - #! Build the prolog for a function - [ - length dup , \ , - [ 1 - ] keep [ - 2dup - [ swap set-array-nth ] cons , \ keep , - ] repeat drop - ] [ ] make ; - -: ast>quot ( args ast -- quot ) - over prologue -rot compile-ast append ; - -: define-math ( seq -- ) - " " join - dup parse-full apply-args uncons car swap - >apply< >r create-in r> - [ "math-args" set-word-prop ] 2keep - >r tuck >r >r swap "code" set-word-prop r> r> r> - rot ast>quot define-compound ; - -: MATH: - #! MATH: sq[x]=x*x ; - "in-definition" on - string-mode on - [ - string-mode off define-math - ] f ; parsing - -: TEST-MATH: - #! Executes and prints the result of a math - #! expression at parsetime - string-mode on [ - " " join string-mode off parse-full - f swap ast>quot call . - ] f ; parsing - -! PREDICATE: compound infix-word "code" word-prop ; -! M: infix-word definer -! drop POSTPONE: MATH: ; -! M: infix-word class. -! "code" word-prop write " ;" print ; -! -! Redefine compound to not include infix words so see works -! IN: words -! USING: kernel words parse-k ; -! -! PREDICATE: word compound -! dup word-primitive 1 = swap infix-word? not and ; - - - -MATH: quadratic[a;b;c] = - plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;