diff --git a/collects/xelda/Physics101.xls b/collects/xelda/Physics101.xls deleted file mode 100644 index 324cbf243f..0000000000 Binary files a/collects/xelda/Physics101.xls and /dev/null differ diff --git a/collects/xelda/currency_table.xls b/collects/xelda/currency_table.xls deleted file mode 100644 index c16a9fef99..0000000000 Binary files a/collects/xelda/currency_table.xls and /dev/null differ diff --git a/collects/xelda/private/formula.ss b/collects/xelda/private/formula.ss deleted file mode 100644 index dff6c17930..0000000000 --- a/collects/xelda/private/formula.ss +++ /dev/null @@ -1,14 +0,0 @@ -(module formula mzscheme - - (provide (all-defined)) - - (define-struct formula (name dependencies) (make-inspector)) - (define-struct (xl-number formula) (val) (make-inspector)) - (define-struct (cell-ref formula) () (make-inspector)) - (define-struct (named-cell-ref cell-ref) (cell-name) (make-inspector)) - (define-struct (binary-op formula) (op arg1 arg2) (make-inspector)) - (define-struct (boolean-op formula) (op arg1 arg2) (make-inspector)) - (define-struct (unary-op formula) (op arg) (make-inspector)) - (define-struct (tbl-top formula) (input-cell) (make-inspector)) - (define-struct (tbl-left formula) (input-cell) (make-inspector)) - (define-struct (application formula) (fun args) (make-inspector))) diff --git a/collects/xelda/private/parser.ss b/collects/xelda/private/parser.ss deleted file mode 100644 index f1d4163367..0000000000 --- a/collects/xelda/private/parser.ss +++ /dev/null @@ -1,297 +0,0 @@ -(module parser mzscheme - - (require mzlib/string) - (require parser-tools/yacc) - (require parser-tools/lex) - (require mzlib/list) - - (require "xl-util.ss") - (require "formula.ss") - - (provide call-parser - make-parser - parse-unit) - - (define (string-downcase s) - (let ([tmp (string-copy s)]) - (string-lowercase! tmp) - tmp)) - - (define-tokens data-tokens - (STRING - QUOTED_STRING - NUMBER - CELL-REF - UNIT - IDENTIFIER)) - - (define-tokens op-tokens - (ADD-OP - MULT-OP - BOOL-OP - TBL-BEGIN - EXP-OP)) - - (define-empty-tokens cmp-tokens - (LT LTE NE GT GTE)) - - (define-empty-tokens syntax-tokens - (INVALID-TOKEN - EOF - EQ - NEG ; for precedence - LPAREN RPAREN - LBRACE RBRACE - COMMA - RANGE-SEP SHEET-SEP)) - - (define-lex-abbrevs - [digit (- "0" "9")] - [pos-digit (- "1" "9")] - [number-sequence (+ digit)] - [number-with-point (@ number-sequence "." number-sequence)] - [unsigned-number (: number-sequence number-with-point)] - [number unsigned-number] - [pos-int (@ pos-digit number-sequence)] - [letter (: (- "a" "z") (- "A" "Z"))] - [letter-to-V (: (- "a" "v") (- "A" "V"))] - [letter-to-I (: (- "a" "h") (- "A" "H"))] - [alphanum_ (: digit letter "_")] - [alphanum (: letter digit)] - [cell-letter-sequence (: letter (@ letter-to-I letter) (@ (: "i" "I") letter-to-V))] - [cell-number-sequence (: pos-digit (@ pos-digit digit) - (@ pos-digit digit digit) - (@ pos-digit digit digit digit))] - [cell-reference (@ (? "$") cell-letter-sequence (? "$") cell-number-sequence)] - [whitespace (: #\space #\tab #\newline #\return)] - [add-op (: "+" "-")] - [mult-op (: "*" "/")] - [exp-op "^"] - [bool-op (: "<" ">" "<=" ">=" "=" "<>")] - [tbl-begin "=TABLE("] - [function-name - (: "NOT" - "AND" - "OR" - "SUM" - "AVERAGE" - "MIN" - "MAX" - )] - [special-unit-chars (: "(" ")" "^" "*" "-" "/")] - [unit-chars (^ (: whitespace special-unit-chars))] - [non-num (^ (: digit whitespace special-unit-chars))] - [unit (@ (* unit-chars) non-num (* unit-chars))] - [identifier (: (@ (* letter) (* alphanum_) "_" (* alphanum_)) - (@ (* alphanum) letter) - (@ letter letter letter (* alphanum)) - (@ (: (- "j" "z") (- "J" "Z")) letter digit) - (@ (: "i" "I") (: (- "w" "z") (- "W" "Z")) digit) - (@ letter "0"))]) - - (define unit-lex - (lexer - [whitespace (unit-lex input-port)] - [(eof) 'EOF] - [number (token-NUMBER (string->number lexeme))] - [mult-op (token-MULT-OP (string->symbol lexeme))] - ["-" (token-MULT-OP (string->symbol lexeme))] - [exp-op (token-EXP-OP (string->symbol lexeme))] - [unit (token-UNIT lexeme)] - ["(" (token-LPAREN)] - [")" (token-RPAREN)])) - - (define xl-lex - (lexer - [whitespace - (xl-lex input-port)] - [(eof) 'EOF] - [number - (token-NUMBER (string->number lexeme))] - [add-op - (token-ADD-OP (string->symbol lexeme))] - [mult-op - (token-MULT-OP (string->symbol lexeme))] - [exp-op - (token-EXP-OP (string->symbol lexeme))] - [bool-op - (token-BOOL-OP (string->symbol lexeme))] - [cell-reference - (token-CELL-REF - (string->symbol - (list->string - (filter (lambda (c) (not (equal? c #\$))) - (string->list (string-downcase lexeme))))))] - [identifier (token-IDENTIFIER lexeme)] - [tbl-begin (token-TBL-BEGIN lexeme)] - [":" (token-RANGE-SEP)] - ["," (token-COMMA)] - ["(" (token-LPAREN)] - [")" (token-RPAREN)] - ["{" (token-LBRACE)] - ["}" (token-RBRACE)] - ["=" (token-EQ)])) - - (define make-parser - (lambda (symbol-table) - (parser - - (start start) - (end EOF) - (error (lambda (a b c) (void))) - (tokens data-tokens - op-tokens - cmp-tokens - syntax-tokens) - - (precs (left ADD-OP) - (left MULT-OP) - (left EXP-OP) - (left BOOL-OP) - (left NEG) - (right LPAREN) - (left RPAREN)) - - (grammar - - (start [() #f] - [(error start) $2] - [(expr) $1]) - - (formula [(EQ expr) $2]) - - (expr - ; cells have their own names - [(CELL-REF) (make-cell-ref $1 (list $1))] - [(IDENTIFIER) - (let ([cell-loc (cadr (assoc $1 symbol-table))]) - (make-named-cell-ref cell-loc (list cell-loc) (string->symbol $1)))] - [(NUMBER) (make-xl-number (gensym) null $1)] - [(TBL-BEGIN expr COMMA RPAREN) - (make-tbl-top - (gensym) - (formula-dependencies $2) - $2)] - [(TBL-BEGIN COMMA expr RPAREN) - (make-tbl-left - (gensym) - (formula-dependencies $3) - $3)] - [(LPAREN expr RPAREN) $2] - [(expr ADD-OP expr) - (make-binary-op - (gensym) - (append (formula-dependencies $1) - (formula-dependencies $3)) - $2 - $1 $3)] - [(expr MULT-OP expr) - (make-binary-op - (gensym) - (append (formula-dependencies $1) - (formula-dependencies $3)) - $2 - $1 $3)] - [(expr EXP-OP expr) - (make-binary-op - (gensym) - (append (formula-dependencies $1) - (formula-dependencies $3)) - $2 - $1 $3)] - [(expr BOOL-OP expr) - (make-boolean-op - (gensym) - (append (formula-dependencies $1) - (formula-dependencies $3)) - $2 - $1 $3)] - [(ADD-OP expr) (prec NEG) - (cond [(xl-number? $2) - (make-xl-number (formula-name $2) - null - (- 0 (xl-number-val $2)))] - [else - (make-unary-op - (gensym) - (formula-dependencies $2) - $1 $2)])] - [(IDENTIFIER LPAREN RPAREN) - (make-application - (gensym) - empty (string->symbol (string-downcase $1)) empty)] - [(IDENTIFIER LPAREN args RPAREN) - (make-application - (gensym) - (cadr $3) (string->symbol (string-downcase $1)) (car $3))]) - - ; returns list of symbols denoting cells - (cell-range - [(CELL-REF RANGE-SEP CELL-REF) - (get-range-cells $1 $3)]) - - ; returns two-elt list, (expr deps) - (arg - [(expr) (list (list $1) (formula-dependencies $1))] - [(cell-range) (list (map (lambda (c) - (make-cell-ref c (list c))) - $1) - $1)]) - (args - [(arg) (list (car $1) (cadr $1))] - [(arg COMMA args) - (let ([arg1 (car $1)] - [dep1 (cadr $1)] - [arg2 (car $3)] - [dep2 (cadr $3)]) - (list (append arg1 arg2) (append dep1 dep2)))]))))) - - (define (call-parser parser s) - (let* ([port (open-input-string s)] - [lex-thunk (lambda () (xl-lex port))]) - (parser lex-thunk))) - - (define unit-parser - (parser - - (start start) - (end EOF) - (error (lambda (a b c) (void))) - (tokens data-tokens - op-tokens - cmp-tokens - syntax-tokens) - - (precs (left MULT-OP) - (left EXP-OP) - (left NEG) - (right LPAREN) - (left RPAREN)) - - (grammar - - (start [() #f] - [(error start) $2] - [(expr) $1]) - - (expr - [(expr EXP-OP expr) - (map (lambda (u) - (cond [(number? $3) (list (first u) (* $3 (second u)))] - [else u])) $1)] - [(expr MULT-OP expr) - (let ([invert (lambda (l) - (map (lambda (u) - (list (first u) (- 0 (second u)))) l))]) - (cond [(eq? $2 '/) (append $1 (invert $3))] - [else (append $1 $3)]))] - [(LPAREN expr RPAREN) $2] - [(LPAREN RPAREN) (list (list 'empty_unit 1))] - [(NUMBER) $1] - [(MULT-OP expr)(prec NEG) (- 0 $2)] - [(UNIT) (list (list (string->symbol $1) 1))])))) - - (define (parse-unit s) - (let* ([port (open-input-string s)] - [lex-thunk (lambda () (unit-lex port))]) - (unit-parser lex-thunk)))) diff --git a/collects/xelda/private/xelda-checker.ss b/collects/xelda/private/xelda-checker.ss deleted file mode 100644 index 3857894d4d..0000000000 --- a/collects/xelda/private/xelda-checker.ss +++ /dev/null @@ -1,1326 +0,0 @@ -(module xelda-checker mzscheme - (require mzlib/class) - (require mzlib/list) - (require mzlib/match) - - (require "xl-util.ss") - (require "formula.ss") - (require "parser.ss") - (require "xelda-lib.ss") - (require "xelda-com.ss") - - (provide unit-check) - - (define (unit-check gui) - (let* ([all-formula-texts - (begin - (send gui update-status (format "+++SPREADSHEET PREPROCESSING BEGIN+++~n")) - (send gui update-status "Preprocessing all formula texts.... ") - (iterate-over-worksheet - (lambda (cell) (get-cell-formula cell)) - (lambda (formula) - (and (not (string=? formula "")) - (eq? (string-ref formula 0) #\=)))))] - [all-names - (begin - (send gui next-update-status "Preprocessing all names") - (iterate-over-worksheet - (lambda (cell) (get-cell-name cell)) - (lambda (s) (not (string=? s "")))))] - [symbol-table - (begin - (send gui next-update-status "Preprocessing symbol-table") - (map (lambda (pr) (list (cadr pr) (car pr))) all-names))] - [parser (make-parser symbol-table)] - [formulas - (begin - (send gui next-update-status "Preprocessing all formulas") - (map (lambda (f) - (let ([cell (car f)] - [form (cadr f)]) - (cond - [(tbl-top? form) - (list cell - (make-tbl-top - (formula-name form) - (append (formula-dependencies form) - (list (top-of cell) - (get-formula-loc-left cell - parser - all-formula-texts))) - (tbl-top-input-cell form)))] - [(tbl-left? form) - (list cell - (make-tbl-left - (formula-name form) - (append (formula-dependencies form) - (list (left-of cell) - (get-formula-loc-up cell - parser - all-formula-texts))) - (tbl-left-input-cell form)))] - [else f]))) - (map (lambda (frm-text) - (list (car frm-text) - (call-parser parser (cadr frm-text)))) - all-formula-texts)))] - [all-formulas (formula-sort formulas)] - [circular-non-circular (split-circular-non-circular all-formulas)] - [all-circular-formulas (first circular-non-circular)] - [all-non-circular-formulas (second circular-non-circular)] - [good-and-bad-units - (split-list - (begin - (send gui next-update-status "Preprocessing all units") - (iterate-over-worksheet - (lambda (cell) - (with-handlers - ([void (lambda _ 'bad-unit-format)]) - (let ([comment-txt (get-cell-comment cell)]) - (cond - [(string=? "" comment-txt) empty] - [else (parse-unit comment-txt)])))) - (lambda (u) (and (not (empty? u)) (pair? u))))) - (lambda (e) (dim? (second e))))] - [all-units - (map (lambda (entry) - (list (car entry) (canonicalize-units (cadr entry)))) - (first good-and-bad-units))] - [bad-format-units (second good-and-bad-units)] - [hashed-units (make-hash-table)] - [hashed-vars (make-hash-table)] - [hashed-constraints-vars (make-hash-table)]) - (send gui update-status (format "done~n")) - (send gui update-status (format "+++SPREADSHEET PREPROCESSING END+++~n")) - - ;; When bad formatted units are present, don't do unit checking - (time - (cond - [(not (empty? bad-format-units)) - (send gui set-bad-format-cells - (map (lambda (u) (car u)) bad-format-units))] - [else - ;; Place all non-formulas units in the computed units(hashed-units) - (init-hash hashed-units - (filter (lambda (u) (not (assq (car u) all-formulas))) - all-units)) - - (send gui update-status (format "+++UNIT CHECKING BEGIN+++~n")) - - ;; Compute non-circular formula units - (send gui update-status "Checking non-circular formulas.... ") - ;;(printf "ALL NON CIRCULAR CELLS:~n~a~n" - ;; (map (lambda (f) (car f)) - ;; (reverse all-non-circular-formulas))) - (for-each (lambda (f) - (compute-cell-unit f hashed-units - all-formulas all-formula-texts parser)) - (reverse all-non-circular-formulas)) - - ;; Compute circular formula units. Start by assigning unit variables. - (send gui next-update-status "Assigning dimension variables for circular formulas"); - (assign-variables hashed-vars hashed-units all-circular-formulas) - - ;; Generate constraints - (send gui next-update-status "Creating constraints") - (let* ([constraints (create-constraints - hashed-units hashed-vars - all-formulas all-circular-formulas all-formula-texts parser)] - [eq-app-cs (split-list constraints (lambda (c) (eq? (first c) '=)))] - [equality-constraints (first eq-app-cs)] - [append-constraints (second eq-app-cs)]) - ;; Create equivalence classes from the equality constraints - (send gui next-update-status "Creating equivalence classes") - ;;(printf "EQUALITY CONSTRAINTS:~n") - ;;(show-constraints equality-constraints) - ;;(printf "APPEND CONSTRAINTS:~n") - ;;(show-constraints append-constraints) - (prune-constraints equality-constraints hashed-constraints-vars) - - ;; Replace variables in append-constraints with their equivalence class - ;; representative variable or unit (unit only for operands where possible) - (let ([append-constraints (replace-equiv-in-constraints hashed-constraints-vars - append-constraints)]) - ;; Flatten the append constraints - (send gui next-update-status "Solving constraints") - ;;(printf "APPEND CONSTRAINTS: ~a~n" append-constraints) - (solve-constraints (gaussian-elimination append-constraints) - hashed-constraints-vars hashed-vars hashed-units) - (send gui update-status (format "done~n")) - (send gui update-status (format "+++UNIT CHECKING END+++~n")) - - ;; Report any error back to the gui - (send gui set-computation-errors - (computation-errors hashed-units all-formula-texts all-formulas)) - (send gui set-mismatch-errors - (mismatch-errors hashed-units all-units all-formula-texts all-formulas))))])))) - - (define (compute-cell-unit _formula hashed-units all-formulas all-formula-texts parser) - (let ([cell-name (car _formula)] - [formula (cadr _formula)]) - (when (not (in-hash? hashed-units cell-name)) - (hash-table-put! - hashed-units cell-name - (let ([unit (compute-formula formula cell-name hashed-units - all-formulas all-formula-texts parser)]) - (cond ((> (length unit) 1) - (filter (lambda (u) (not (eq? (car u) 'empty_unit))) - unit)) - (else unit))))))) - - (define (compute-formula formula cell-loc hashed-units all-formulas all-formula-texts parser) - (match formula - [($ xl-number name deps val) (empty-unit)] - [($ cell-ref name cell-name) - (cond - [(in-hash? hashed-units name) - (hash-table-get hashed-units name)] - [(not (not (assq name all-formulas))) - (let ([u (compute-formula (cadr (assq name all-formulas)) - name - hashed-units - all-formulas - all-formula-texts - parser)]) - (hash-table-put! hashed-units name u) - u)] - [(string=? "" (get-cell-text (formula-name formula))) - (list (list 'error/empty-formula cell-loc))] - [else (empty-unit)])] - [($ named-cell-ref name cell-name actual-name) - (cond - [(in-hash? hashed-units name) - (hash-table-get hashed-units name)] - [(not (not (assq name all-formulas))) - (let ([u (compute-formula (cadr (assq name all-formulas)) - name - hashed-units - all-formulas - all-formula-texts - parser)]) - (hash-table-put! hashed-units name u) - u)] - [(string=? "" (get-cell-text (formula-name formula))) - (list (list 'error/empty-formula cell-loc))] - [else (empty-unit)])] - [($ binary-op name deps op arg1 arg2) - (let ([arg1-unit (compute-formula arg1 - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)] - [arg2-unit (compute-formula arg2 - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)]) - (case op - [(+ -) (check-equal-units (list arg1-unit arg2-unit) cell-loc)] - [(*) (let ([result (gen-mult-units arg1-unit arg2-unit cell-loc)]) - (cond ((null? result) (empty-unit)) - (else result)))] - [(/) (let ([result (gen-div-units arg1-unit arg2-unit cell-loc)]) - (cond ((null? result) (empty-unit)) - (else result)))] - [(^) (gen-exp-units arg1-unit - (cond - [(xl-number? arg2) (xl-number-val arg2)] - [(or (cell-ref? arg2) - (named-cell-ref? arg2)) - (get-cell-value (formula-name arg2))] - [else 'bad-exp]) cell-loc)]))] - [($ boolean-op name deps op arg1 arg2) - (let ([arg1-unit (compute-formula arg1 - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)] - [arg2-unit (compute-formula arg2 - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)]) - (if (equal? arg1-unit arg2-unit) - (empty-unit) - (list (list 'error/bool-non-empty cell-loc))))] - [($ unary-op name deps op arg) - (let ([arg-unit (compute-formula arg - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)]) - (case op - [(+ -) arg-unit] - [else (error op "Unknown unary op")]))] - [($ tbl-left name deps input-cell) - (let ([left-cell (left-of cell-loc)] - [formula-cell (get-formula-loc-up cell-loc parser all-formula-texts)] - [left-cell-unit empty] - [input-cell-unit (compute-formula input-cell - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)]) - (if (in-hash? hashed-units left-cell) - (set! left-cell-unit (hash-table-get hashed-units left-cell)) - (set! left-cell-unit (compute-cell-unit (assoc left-cell all-formulas) - hashed-units - all-formulas all-formula-texts parser))) - (compute-formula (replace-in-formula - (cadr (assq formula-cell all-formulas)) - (formula-name input-cell) left-cell) - cell-loc - hashed-units - all-formulas - all-formula-texts - parser))] - [($ tbl-top name deps input-cell) - (let ([input-cell-unit (compute-formula input-cell - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)] - [top-cell (top-of cell-loc)] - [formula-cell (get-formula-loc-left cell-loc parser all-formula-texts)] - [top-cell-unit empty]) - (if (in-hash? hashed-units top-cell) - (set! top-cell-unit (hash-table-get hashed-units top-cell)) - (set! top-cell-unit (compute-cell-unit (assoc top-cell all-formulas) - hashed-units - all-formulas all-formula-texts parser))) - (compute-formula (replace-in-formula - (cadr (assq formula-cell all-formulas)) - (formula-name input-cell) top-cell) - cell-loc - hashed-units - all-formulas - all-formula-texts - parser))] - [($ application name deps fun args) - (let ([arg-units (map (lambda (a) - (compute-formula a - cell-loc - hashed-units - all-formulas - all-formula-texts - parser)) args)]) - (case fun - [(average sum min max mina maxa) (check-equal-units arg-units cell-loc)] - [(not or and) - (if (andmap empty-unit? arg-units) - (empty-unit) - (list (list 'error/bool-non-empty cell-loc)))] - [(if) (cond - ((= 3 (length args)) - (let ([if-unit (second arg-units)] - [else-unit (third arg-units)] - [test-unit (first arg-units)]) - (if (empty-unit? test-unit) - (check-equal-units (list if-unit else-unit) cell-loc) - (list (list 'error/if-bool-non-empty cell-loc))))) - (else (error fun "illegal use")))] - [(abs) (cond - ((= 1 (length args)) (first arg-units)) - (else (error fun "illegal use")))] - [(ceiling round) - (cond - ((= 2 (length args)) - (let ([num-unit (first arg-units)] - [prec-unit (second arg-units)]) - (cond - ((empty-unit? prec-unit) num-unit) - (else (list (list 'error/non-empty-precision cell-loc)))))) - (else (error fun "illegal use")))] - [(large) (let ([split-units (split-large-args arg-units)]) - (cond - ((= 1 (length (car split-units))) - (check-equal-units (cadr split-units) cell-loc)) - (else (list (list 'error/large-empty-unit cell-loc)))))] - [(acos acosh asin asinh atan atanh cos cosh sin sinh tan tanh exp) - (let ([arg-unit (first arg-units)]) - (cond ((= 1 (length args)) - (if (empty-unit? arg-unit) - arg-unit - (list (list 'error/non-empty-argument cell-loc)))) - (else (error fun "illegal use"))))] - [(sqrt) (let ([arg-unit (first arg-units)]) - (cond - ((= 1 (length args)) - (cond [(empty-unit? arg-unit) arg-unit] - [(andmap (lambda (s_u) - (= (modulo (cadr s_u) 2) 0)) - arg-unit) - (map (lambda (s_u) - (list (car s_u) (/ (cadr s_u) 2))) - arg-unit)] - [else - (list (list 'error/invalid-sqrt-dimension cell-loc))])) - (else (error fun "illegal use"))))] - [(fact ln log) (let ([arg-unit (first arg-units)]) - (cond - ((= 1 (length args)) - (if (empty-unit? arg-unit) - arg-unit - (list (list 'error/non-unitless-argument cell-loc)))) - (else (error fun "illegal use"))))] - [(isnumber) - (cond ((= 1 (length arg-units)) (empty-unit)) - (else (error fun "illegal use")))] - [(median stdev) (check-equal-units arg-units cell-loc)] - [(npv) (cond - [(>= (length args) 2) - (cond [(empty-unit? (first arg-units)) - (let ([u (first (rest arg-units))]) - (foldl (lambda (curr prev) (check-equal-units curr prev)) - u - (rest (rest arg-units))))] - [else - (list (list 'error/npv-rate-non-dimensionless cell-loc))])] - [else (error fun "illegal use")])] - [(intercept) - (cond - [(> (length arg-units) 0) - (let* ([x-unit (first arg-units)] - [xy-units (split-list (rest arg-units) (lambda (u) (equal? u x-unit)))] - [x-units (cons x-unit (first xy-units))] - [y-units (second xy-units)]) - (cond [(= (length x-units) (length y-units)) - (check-equal-units y-units cell-loc)] - [else (list (list 'error/intercept-invalid-points cell-loc))]))] - [else (empty-unit)])] - [(count) (empty-unit)] - [(frequency) - (let ([args-unit (check-equal-units arg-units cell-loc)]) - (cond [(is-error-unit? args-unit) args-unit] - [else (empty-unit)]))] - [(mod) - (cond ((= 2 (length arg-units)) (first arg-units)) - (else (error fun "illegal use")))] - [(na pi today now) (cond ((empty? args) (empty-unit)) - (else (error fun "illegal use")))] - [(mmult) (let* ([formula-text (lookup-formula-text cell-loc all-formula-texts)] - [Ms (identify-matrices - (substring formula-text 7 - (sub1 (string-length formula-text))))]) - (cond - [(= 2 (length Ms)) - (let* ([cell-xy (get-cell-row-col cell-loc)] - [M1-row (car cell-xy)] - [M2-col (cadr cell-xy)] - [M1-row-unit (check-equal-units - (matrix-row-units (car Ms) M1-row hashed-units) - cell-loc)] - [M2-col-unit (check-equal-units - (matrix-col-units (cadr Ms) M2-col hashed-units) - cell-loc)]) - (cond - [(is-error-unit? M1-row-unit) M1-row-unit] - [(is-error-unit? M2-col-unit) M2-col-unit] - [else (gen-mult-units M1-row-unit M2-col-unit cell-loc)]))] - [else (error fun "illegal use")]))] - [else (empty-unit)]))])) ;; unimplemented functions -> empty unit - - (define (replace-in-formula formula orig new) - (match formula - [($ xl-number name deps val) formula] - [($ cell-ref name cell-name) - (cond - [(eq? name orig) (make-cell-ref new empty)] - [else formula])] - [($ named-cell-ref name cell-name actual-name) formula] - [($ binary-op name deps op arg1 arg2) - (make-binary-op name deps op - (replace-in-formula arg1 orig new) - (replace-in-formula arg2 orig new))] - [($ boolean-op name deps op arg1 arg2) - (make-boolean-op name deps op - (replace-in-formula arg1 orig new) - (replace-in-formula arg2 orig new))] - [($ unary-op name deps op arg) - (make-unary-op name deps op (replace-in-formula arg orig new))] - [($ tbl-left name deps input-cell) - (cond [(eq? input-cell orig) - (make-tbl-left name deps new)] - [else formula])] - [($ tbl-top name deps input-cell) - (cond [(eq? input-cell orig) - (make-tbl-top name deps new)] - [else formula])] - [($ application name deps fun args) - (let ([replaced-args - (map (lambda (a) - (replace-in-formula a orig new)) args)]) - (make-application name deps fun replaced-args))] - [else formula])) - - (define (remove-duplicates lst) - (cond - [(null? lst) null] - [(member (car lst) (cdr lst)) (remove-duplicates (cdr lst))] - [else (cons (car lst) (remove-duplicates (cdr lst)))])) - - (define (formula-sort fs) - (sort fs (lambda (f1 f2) - (let* ([name (car f1)] - [deps (formula-dependencies (cadr f2))]) - (memq name deps))))) - - (define (get-formula-loc-up loc parser all-formula-texts) - (let ([formula (call-parser parser (cadr (assoc loc all-formula-texts)))]) - (cond ((not (tbl-left? formula)) loc) - (else (let* ([xy (cellref->numbers loc)] - [x (sub1 (car xy))] - [y (sub1 (cadr xy))]) - (get-formula-loc-up (numbers->cellref (list x y)) - parser all-formula-texts)))))) - - (define (get-formula-loc-left loc parser all-formula-texts) - (let ([formula (call-parser parser (cadr (assoc loc all-formula-texts)))]) - (cond ((not (tbl-top? formula)) loc) - (else (let* ([xy (cellref->numbers loc)] - [x (- (car xy) 2)] - [y (cadr xy)]) - (get-formula-loc-left (numbers->cellref (list x y)) - parser all-formula-texts)))))) - - (define (assign-variables hashed-vars hashed-units all-circular-formulas) - (for-each (lambda (f) - (let ([a_s (gen-alpha-var)]) - (hash-table-put! hashed-vars a_s - (list (car f) (list (list 'error/missing-dimensions (car f))))) - (hash-table-put! hashed-units (car f) a_s))) - all-circular-formulas)) - - (define (gen-alpha-var) - (string->symbol (string-append "a_" (symbol->string (gensym))))) - - (define (gen-beta-var) - (string->symbol (string-append "b_" (symbol->string (gensym))))) - - (define (alpha-var? a) - (and (symbol? a) - (let [(l (string->list (symbol->string a)))] - (and (> (length l) 3) - (equal? (first l) #\a) - (equal? (second l) #\_) - (equal? (third l) #\g))))) - - (define (beta-var? b) - (and (symbol? b) - (let [(l (string->list (symbol->string b)))] - (and (> (length l) 3) - (equal? (first l) #\b) - (equal? (second l) #\_) - (equal? (third l) #\g))))) - - (define (dim-var? s) (or (alpha-var? s) (beta-var? s))) - - (define (dim? u) (and (list? u) - (andmap (lambda (u_) - (and (list? u_) - (= 2 (length u_)) - (symbol? (car u_)) - (integer? (cadr u_)))) u))) - - (define (constraint-var c) (second c)) - (define (constraint-operator c) (first c)) - (define (constraint-left-side c) (third c)) - (define (constraint-right-side c) (fourth c)) - - (define (create-constraints hashed-units hashed-vars - all-formulas all-circular-formulas all-formula-texts parser) - (foldl (lambda (f constraints) - (let ([a_s (hash-table-get hashed-units (car f))]) - (create-constraints-for-formula a_s (cadr f) (car f) constraints - hashed-units hashed-vars - all-formulas all-formula-texts parser))) - empty all-circular-formulas)) - - (define (create-constraints-for-formula sym formula cell-loc formula-constraints - hashed-units hashed-vars - all-formulas all-formula-texts parser) - (match formula - [($ xl-number name deps val) - (cons (list '= sym (empty-unit)) formula-constraints)] - [($ cell-ref name cell-name) - (cond [(in-hash? hashed-units name) - (cons - (list '= sym (hash-table-get hashed-units name)) - formula-constraints)] - [else (cons (list '= sym (empty-unit)) formula-constraints)])] - [($ named-cell-ref name cell-name actual-name) - (cond [(in-hash? hashed-units name) - (cons - (list '= sym (hash-table-get hashed-units name)) - formula-constraints)] - [else (cons (list '= sym (empty-unit)) formula-constraints)])] - [($ binary-op name deps op arg1 arg2) - (let* ([left-op (gen-beta-var)] - [right-op (gen-beta-var)] - [new-constraints - (create-constraints-for-formula - left-op arg1 cell-loc - (create-constraints-for-formula - right-op arg2 cell-loc formula-constraints hashed-units hashed-vars - all-formulas all-formula-texts parser) - hashed-units hashed-vars all-formulas all-formula-texts parser)]) - (case op - [(+ -) - (cons (list '= sym left-op) - (cons (list '= sym right-op) new-constraints))] - [(*) - (cons (list '@ sym left-op right-op) new-constraints)] - [(/) - (cons (list '@/ sym left-op right-op) new-constraints)] - [(^) - (cons (list '= right-op (empty-unit)) new-constraints)]))] - [($ boolean-op name deps op arg1 arg2) - (let* ([left-op (gen-beta-var)] - [right-op (gen-beta-var)] - [new-constraints - (create-constraints-for-formula - left-op arg1 cell-loc - (create-constraints-for-formula - right-op arg2 cell-loc formula-constraints hashed-units hashed-vars - all-formulas all-formula-texts parser) - hashed-units hashed-vars all-formulas all-formula-texts parser)]) - (cons (list '= left-op right-op) - (cons (list '= sym (empty-unit)) new-constraints)))] - [($ unary-op name deps op arg) - (let ([op-sym (gen-beta-var)]) - (cons (list '= sym op-sym) - (create-constraints-for-formula op-sym arg cell-loc formula-constraints - hashed-units hashed-vars - all-formulas all-formula-texts parser)))] - [($ tbl-left name deps input-cell) - (let* ([left-cell (left-of cell-loc)] - [formula-cell (get-formula-loc-up cell-loc parser all-formula-texts)] - [formula-sym (gen-beta-var)]) - (cons (list '= sym formula-sym) - (create-constraints-for-formula - formula-sym - (replace-in-formula (cadr (assq formula-cell all-formulas)) - (formula-name input-cell) left-cell) - formula-cell formula-constraints hashed-units hashed-vars - all-formulas all-formula-texts parser)))] - [($ tbl-top name deps input-cell) - (let* ([top-cell (top-of cell-loc)] - [formula-cell (get-formula-loc-left cell-loc parser all-formula-texts)] - [formula-sym (gen-beta-var)]) - (cons (list '= sym formula-sym) - (create-constraints-for-formula - formula-sym - (replace-in-formula (cadr (assq formula-cell all-formulas)) - (formula-name input-cell) top-cell) - formula-cell formula-constraints hashed-units hashed-vars - all-formulas all-formula-texts parser)))] - [($ application name deps fun args) - (let* ([arg-syms (map (lambda (a) (gen-beta-var)) args)] - [arg-constraints - (letrec ([gen-arg-constraints - (lambda (as as-syms) - (cond - [(empty? as) formula-constraints] - [else - (create-constraints-for-formula - (first as-syms) (first as) cell-loc - (gen-arg-constraints (rest as) (rest as-syms)) - hashed-units hashed-vars - all-formulas all-formula-texts parser)]))]) - (gen-arg-constraints args arg-syms))]) - (case fun - [(average sum min max mina maxa) - (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints)) - arg-constraints arg-syms)] - [(not or and) - (cons (list '= sym (empty-unit)) - (foldl (lambda (arg constraints) (cons (list '= sym empty-unit) constraints)) - arg-constraints arg-syms))] - [(if) (cond - [(= 3 (length args)) - (let ([if-sym (second arg-syms)] - [else-sym (third arg-syms)] - [test-sym (first arg-syms)]) - (cons (list '= test-sym (empty-unit)) - (cons (list '= if-sym else-sym) - (cons (list '= sym if-sym) arg-constraints))))] - [else (error fun "illegal use")])] - [(abs) (cond - [(= 1 (length args)) (cons (list '= sym (first arg-syms) arg-constraints))] - [else (error fun "illegal use")])] - [(ceiling round) - (cond - [(= 2 (length args)) - (let ([num-sym (first arg-syms)] - [prec-sym (second arg-syms)]) - (cons (list '= prec-sym (empty-unit)) - (cons (list '= sym num-sym) arg-constraints)))] - [else (error fun "illegal use")])] - [(large) (let* ([reversed-syms (reverse arg-syms)] - [k-sym (first reversed-syms)] - [array-syms (rest reversed-syms)]) - (cons (list '= k-sym (empty-unit)) - (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints)) - arg-constraints array-syms)))] - [(acos acosh asin asinh atan atanh cos cosh sin sinh tan tanh exp) - (let ([arg-sym (first arg-syms)]) - (cond [(= 1 (length args)) - (cons (list '= arg-sym (empty-unit)) - (cons (list '= sym (empty-unit)) arg-constraints))] - [else (error fun "illegal use")]))] - [(sqrt) (let ([arg-sym (first arg-syms)]) - (cond - [(= 1 (length args)) - (cons (list '@/ sym arg-sym sym) arg-constraints)] - [else (error fun "illegal use")]))] - [(fact ln log) (let ([arg-sym (first arg-syms)]) - (cond - [(= 1 (length args)) - (cons (list '= arg-sym (empty-unit)) - (cons (list '= sym (empty-unit)) arg-constraints))] - [else (error fun "illegal use")]))] - [(isnumber) - (cond [(= 1 (length arg-syms)) (cons (list '= sym (empty-unit)) arg-constraints)] - [else (error fun "illegal use")])] - [(median stdev) - (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints)) - arg-constraints arg-syms)] - [(npv) - (cond [(>= (length args) 2) - (cons (cons '= (first arg-syms) (empty-unit)) - (foldl (lambda (arg constraints) (cons (list '= sym arg) constraints)) - arg-constraints (rest arg-syms)))] - [else (error fun "illegal use")])] - [(count) (cons (list '= sym (empty-unit)) arg-constraints)] - [(frequency) - (when (not (empty? arg-syms)) - (let ([first-sym (first arg-syms)]) - (cons (list '= sym (empty-unit)) - (foldl (lambda (arg constraints) (cons (list '= first-sym arg) constraints)) - arg-constraints (rest arg-syms)))))] - [(mod) - (cond [(= 2 (length args)) (cons (list '= sym (first arg-syms)) arg-constraints)] - [else (error fun "illegal use")])] - [(na pi today now) - (cond [(empty? args) (cons (list '= sym (empty-unit)) arg-constraints)] - [else (error fun "illegal use")])] - [(mmult) (let* ([formula-text (lookup-formula-text cell-loc all-formula-texts)] - [Ms (identify-matrices - (substring formula-text 7 - (sub1 (string-length formula-text))))]) - (cond - [(= 2 (length Ms)) - (let* ([cell-xy (get-cell-row-col cell-loc)] - [M1-row (car cell-xy)] - [M2-col (cadr cell-xy)] - [M1-row-sym (gen-beta-var)] - [M2-col-sym (gen-beta-var)] - [row-syms-constraints (matrix-row-syms (car Ms) M1-row - hashed-units hashed-vars)] - [row-syms (first row-syms-constraints)] - [row-constraints (second row-syms-constraints)] - [col-syms-constraints (matrix-col-syms (cadr Ms) M2-col - hashed-units hashed-vars)] - [col-syms (first col-syms-constraints)] - [col-constraints (second col-syms-constraints)]) - (cons (list '@ sym M1-row-sym M2-col-sym) - (foldl (lambda (arg constraints) - (cons (list '= M1-row-sym arg) constraints)) - (foldl (lambda (arg constraints) - (cons (list '= M2-col-sym arg) constraints)) - (append arg-constraints row-constraints - col-constraints) - col-syms) - row-syms)))] - [else (error fun "illegal use")]))] - [else (cons (list '= sym (list (list 'error/unimplemented-function 1))) - arg-constraints)]))])) - - (define (prune-constraints equality-constraints hashed-constraints-vars) - (for-each (lambda (c) - (let* ([syms (cond [(or (dim? (second c)) (is-error-unit? (second c))) - (list (third c) (second c))] - [else (list (second c) (third c))])] - [sym1 (first syms)] - [sym2 (second syms)]) - (if (or (dim? sym2) (is-error-unit? sym2)) - (resolve-var-dim sym1 sym2 hashed-constraints-vars) - (resolve-var-var sym1 sym2 hashed-constraints-vars)))) - equality-constraints)) - - (define (replace-equiv-in-constraints hashed-constraints-vars append-constraints) - (let* ([replace-head - (lambda (var) - (cond - [(in-hash? hashed-constraints-vars var) - (first (find-rep (first (hash-table-get hashed-constraints-vars var))))] - [else var]))] - [replace-operands - (lambda (operands) - (let ([replace-op - (lambda (op) - (if (dim-var? op) - (cond - [(in-hash? hashed-constraints-vars op) - (let* ([rep (first - (find-rep - (first (hash-table-get hashed-constraints-vars op))))] - [rep-u (second (hash-table-get hashed-constraints-vars rep))]) - (if (empty? rep-u) - (list (list rep 1)) - rep-u))] - [else (list (list op 1))]) - op))]) - (append (replace-op (first operands)) (replace-op (second operands)))))] - [map-replace - (lambda (c) - (cons (replace-head (second c)) - (cons '= (replace-operands (rest (rest c))))))]) - (remove-duplicates (map map-replace append-constraints)))) - - (define (resolve-var-dim var u hashed-constraints-vars) - (if (not (in-hash? hashed-constraints-vars var)) - (hash-table-put! hashed-constraints-vars var (list (make-equiv-class var) u)) - (let* ([tbl-entry (hash-table-get hashed-constraints-vars var)] - [rep (first (find-rep (first tbl-entry)))] - [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)]) - (let ([var-u - (cond [(empty? (second tbl-entry)) u] - [(not (or (equal? (second tbl-entry) u) - (is-error-unit? (second tbl-entry)))) - (cond [(is-error-unit? u) u] - [else (list (list 'error/equality var))])] - [else u])]) - (hash-table-put! hashed-constraints-vars var - (list (first tbl-entry) var-u)) - (let ([rep-u - (cond [(empty? (second rep-tbl-entry)) var-u] - [(not (or (equal? (second rep-tbl-entry) u) - (is-error-unit? (second rep-tbl-entry)))) - (cond [(is-error-unit? u) u] - [else (list (list 'error/equality rep))])] - [else var-u])]) - (hash-table-put! hashed-constraints-vars rep - (list (first rep-tbl-entry) rep-u))))))) - - (define (resolve-var-var var1 var2 hashed-constraints-vars) - (when (not (in-hash? hashed-constraints-vars var1)) - (hash-table-put! hashed-constraints-vars var1 (list (make-equiv-class var1) empty))) - (when (not (in-hash? hashed-constraints-vars var2)) - (hash-table-put! hashed-constraints-vars var2 (list (make-equiv-class var2) empty))) - (let ([var1-tbl-entry (hash-table-get hashed-constraints-vars var1)] - [var2-tbl-entry (hash-table-get hashed-constraints-vars var2)]) - (union (first (hash-table-get hashed-constraints-vars var1)) - (first (hash-table-get hashed-constraints-vars var2))) - (let* ([var1-u (second var1-tbl-entry)] - [var2-u (second var2-tbl-entry)] - [var-u - (cond [(empty? var1-u) var2-u] - [(empty? var2-u) var1-u] - [(not (equal? var1-u var2-u)) - (list (list 'error/equality var1))] - [else var1-u])] - [rep (first (find-rep (first var1-tbl-entry)))] - [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)] - [rep-u (second rep-tbl-entry)] - [new-u - (cond [(empty? var-u) rep-u] - [(empty? rep-u) var-u] - [(not (equal? var-u rep-u)) - (list (list 'error/equality rep))] - [else var-u])]) - (hash-table-put! hashed-constraints-vars var1 - (list (first var1-tbl-entry) new-u)) - (hash-table-put! hashed-constraints-vars var2 - (list (first var2-tbl-entry) new-u)) - (hash-table-put! hashed-constraints-vars rep - (list (first rep-tbl-entry) new-u))))) - - (define (filter-out-bad-constraints cs) - (let* ([bad-vars (make-hash-table)] - [new-cs - (filter - (lambda (c) - (let ([right-side (rest (rest c))] - [left-side (first c)]) - (cond [(or (not (assq left-side right-side)) - (andmap (lambda (u) (dim-var? (first u))) right-side)) #t] - [else - (cond [(dim-var? (first (first right-side))) - (hash-table-put! bad-vars (first (first right-side)) - '((error/circular 1)))] - [else - (hash-table-put! bad-vars (first (second right-side)) - '((error/circular 1)))]) - #f]))) - cs)]) - new-cs)) - - (define (rearrange-constraints cs) - (map (lambda (c) - (let ([right-side (rest (rest c))] - [left-side (first c)]) - (cond [(not (assq left-side right-side)) - (cons (list left-side -1) right-side)] - [else - (filter - (lambda (u) (not (= 0 (second u)))) - (map (lambda (u) - (cond [(eq? left-side (first u)) - (list (first u) (sub1 (second u)))] - [else u])) - right-side))]))) - cs)) - - (define (ordered-variables eqs) - (remove-duplicates - (sort - (foldl (lambda (eq vars) - (append - (foldl (lambda (u eq-vars) - (cond [(dim-var? (first u)) (cons (first u) eq-vars)] - [else eq-vars])) - empty eq) - vars)) - empty eqs) - (lambda (var1 var2) (stringstring var1) (symbol->string var2)))))) - - (define (reorder-eqs eqs) - (let ([ordered-vars (ordered-variables eqs)]) - (list - ordered-vars - (map - (lambda (eq) - (let* ([vars-dims (split-list eq (lambda (u) (dim-var? (first u))))] - [vars (first vars-dims)]) - (list - (map - (lambda (var) - (let ([var-exp (assq var vars)]) - (cond [var-exp (second var-exp)] - [else 0]))) - ordered-vars) - (second vars-dims)))) - eqs)))) - - (define (reduce eq) - (foldr - (lambda (u new-eq) - (cond [(= 0 (second u)) new-eq] - [(assq (first u) new-eq) - (filter - (lambda (u) (not (= 0 (second u)))) - (map (lambda (u_new) - (cond [(eq? (first u) (first u_new)) - (list (first u) (+ (second u) (second u_new)))] - [else u_new])) - new-eq))] - [else (cons u new-eq)])) - empty eq)) - - (define (first-n l n) - (cond [(> n (length l)) l] - [else - (letrec ([loop (lambda (l n) - (cond [(>= 0 n) empty] - [else (cons (first l) (loop (rest l) (sub1 n)))]))]) - (loop l n))])) - - (define (normalize-unit us) - (let* ([sorted-us (sort us (lambda (u1 u2) - (string<=? (symbol->string (car u1)) - (symbol->string (car u2)))))] - [new-u (filter - (lambda (u) - (not (= 0 (second u)))) - (foldr (lambda (u new-us) - (cond - [(eq? 'empty_unit (first u)) new-us] - [(assq (first u) new-us) - (map (lambda (new_u) - (cond [(eq? (first new_u) (first u)) - (list (first u) (+ (second u) (second new_u)))] - [new_u])) - new-us)] - [else (cons u new-us)])) - empty sorted-us))]) - (cond [(empty? new-u) (empty-unit)] - [else new-u]))) - - (define (select-nth eqs eqn n) - (letrec ([split - (lambda (eqs i) - (cond [(>= i (length eqs)) (list empty eqs)] - [else - (let* ([eq-i (list-ref eqs i)] - [row (first eq-i)] - [nth-val (list-ref row n)]) - (cond [(not (= 0 nth-val)) - (list - (list - (map (lambda (val) (/ val nth-val)) row) - (normalize-unit - (map (lambda (u) (list (first u) (/ (second u) nth-val))) - (second eq-i)))) - (append (first-n eqs i) (list-tail eqs (add1 i))))] - [else (split eqs (add1 i))]))]))]) - (let* ([nth-rest (split eqs 0)] - [nth-eq (first nth-rest)] - [nth-eq-u (cond [(empty? nth-eq) (empty-unit)] - [else (second nth-eq)])] - [transform - (lambda (eqs kth-eq) - (map - (lambda (eq) - (let* ([row (first eq)] - [kth-row (first kth-eq)] - [nth-eq (list-ref row n)] - [nth-kth-eq (list-ref kth-row n)] - [ratio (/ nth-eq nth-kth-eq)]) - (letrec ([simplify - (lambda (i) - (cond [(>= i (length row)) empty] - [else (cons (- (list-ref row i) - (* ratio (list-ref kth-row i))) - (simplify (add1 i)))]))]) - (cond [(= 0 ratio) eq] - [else (list (simplify 0) - (normalize-unit - (append (second eq) - (map (lambda (u) (list (first u) (* (- 0 ratio) (second u)))) - nth-eq-u))))])))) - eqs))]) - ;;(printf "NTH-EQ: ~a || n = ~a~n" nth-eq n) - ;;(printf "TRANSFORMED REST: ~a~n" (transform (second nth-rest) nth-eq)) - (cond [(empty? (first nth-rest)) (list eqs eqn)] - [else - (let ([transformed-eq (transform (second nth-rest) nth-eq)]) - (cond [(ormap (lambda (eq) (and (andmap (lambda (v) (= 0 v)) (first eq)) - (not (or (empty? (second eq)) - (eq? (first (first (second eq))) 'empty_unit))))) - transformed-eq) - (list - (cons (list (first nth-eq) '((error/circular 1))) transformed-eq) - (add1 eqn))] - [else - (list - (cons nth-eq transformed-eq) - (add1 eqn))]))])))) - - (define (modify-eqs eqs) - (let* ([order-eqs (reorder-eqs eqs)] - [ordered-vars (first order-eqs)] - [eqs (second order-eqs)] - [select-eq-for-n-var - (lambda (eqs eqn n) - ;;(printf "EQS:~a~n" eqs) - (let* ([good-eqs (first-n eqs eqn)] - [mod-eqs (list-tail eqs eqn)] - [meqs-eqn (select-nth mod-eqs eqn n)]) - ;;(printf "SELECT-NTH MEQS-EQN: ~a~n" meqs-eqn) - (list (append good-eqs (first meqs-eqn)) (second meqs-eqn))))]) - (letrec ([modify - (lambda (eqs n eqn) - (cond [(>= n (length ordered-vars)) - (list ordered-vars (first-n eqs eqn))] - [else - (let ([neweqs-eqn (select-eq-for-n-var eqs eqn n)]) - ;;(printf "NEW-EQS-EQN: ~a~n" neweqs-eqn) - (modify (first neweqs-eqn) (+ n 1) (second neweqs-eqn)))]))]) - (modify eqs 0 0)))) - - (define (gaussian-elimination append-constraints) - (let* ([eqs (rearrange-constraints - (filter-out-bad-constraints append-constraints))] - [order-triang-eqs (modify-eqs eqs)] - [ordered-vars (first order-triang-eqs)]) - ;;(printf "EQS: ~a~n" eqs) - ;;(printf "ORDERED TRIANG EQS: ~a~n" order-triang-eqs) - (letrec ([nth-var (lambda (row n) (cond [(= 0 (length row)) -1] - [(= 1 (first row)) n] - [else (nth-var (rest row) (add1 n))]))]) - (map - (lambda (var-sol) - (list (first var-sol) - (cond [(ormap (lambda (u) (not (integer? (second u)))) (second var-sol)) - '((error/circular 1))] - [else (second var-sol)]))) - (foldr - (lambda (eq sols) - (let* ([n (nth-var (first eq) 0)] - [var (list-ref ordered-vars n)]) - ;;(printf "eq: ~a || n = ~a || nth-var = ~a~n" (first eq) n var) - (cons - (list - var - (letrec [(computed-u (lambda (n) - (cond [(>= n (length (first eq))) empty] - [else - (let* ([n-var (list-ref ordered-vars n)] - [var-exp (assq n-var sols)]) - ;;(printf "n-var = ~a || var-exp = ~a~n" n-var var-exp) - (cond - [var-exp - (let ([factor (- 0 (list-ref (first eq) n))]) - (append (map (lambda (u) (list (first u) (* factor (second u)))) - (second var-exp)) - (computed-u (add1 n))))] - [else '((error/circular 1))]))])))] - (let ([c-u (computed-u (add1 n))]) - ;;(printf "VAR = ~a | c-u = ~a | second eq = ~a~n" var c-u (second eq)) - (cond [(ormap (lambda (u) (or (eq? (first u) 'error/circular) - (not (integer? (second u))))) - c-u) - '((error/circular 1))] - [else (normalize-unit - (append c-u (map (lambda (u) (list (first u) (- 0 (second u)))) (second eq))))])))) - sols))) - empty - (second order-triang-eqs)))))) - - (define (solve-constraints solved-constraints - hashed-constraints-vars hashed-vars hashed-units) - ;;(printf "HASHED VARS:~n") - ;;(all-hashed-values hashed-vars) - ;;(printf "HASHED CONSTRAINTS:~n") - ;;(all-hashed-values hashed-constraints-vars) - ;;(printf "SOLVED CONSTRAINTS: ~a~n" solved-constraints) - (for-each (lambda (c) (resolve-var-dim (first c) (second c) hashed-constraints-vars)) - solved-constraints) - ;;(printf "HASHED CONSTRAINTS AFTER GAUSSIAN:~n") - ;;(all-hashed-values hashed-constraints-vars) - (resolve-constraints-vars hashed-constraints-vars) - ;;(printf "HASHED CONSTRAINTS AFTER RESOLVE:~n") - ;;(all-hashed-values hashed-constraints-vars) - (replace-constraints-vars hashed-constraints-vars hashed-vars hashed-units)) - - (define (resolve-constraints-vars hashed-constraints-vars) - (hash-table-for-each - hashed-constraints-vars - (lambda (var vals) - (let* ([var-u (second vals)] - [rep (first (find-rep (first vals)))] - [rep-tbl-entry (hash-table-get hashed-constraints-vars rep)] - [rep-u (second rep-tbl-entry)]) - (when (not (eq? var rep)) - (let ([new-u - (cond [(empty? rep-u) var-u] - [(and (not (empty? var-u)) (not (equal? rep-u var-u))) - (list (list 'error/equality rep))] - [else rep-u])]) - (hash-table-put! hashed-constraints-vars rep - (list (first rep-tbl-entry) new-u))))))) - (hash-table-for-each - hashed-constraints-vars - (lambda (var vals) (hash-table-put! - hashed-constraints-vars var - (list (first vals) - (second (hash-table-get - hashed-constraints-vars - (first (find-rep (first vals)))))))))) - - (define (replace-constraints-vars hashed-constraints-vars hashed-vars hashed-units) - (hash-table-for-each - hashed-constraints-vars - (lambda (var val) - (when (alpha-var? var) - (let ([cell-loc (first (hash-table-get hashed-vars var))] - [u (second val)]) - (when (not (empty? u)) - (when (is-error-unit? u) - (set! u (list (list (first (first u)) cell-loc)))) - (hash-table-put! hashed-vars var (list cell-loc u))))))) - (hash-table-for-each - hashed-vars - (lambda (var val) - (let ([cell-loc (first val)] - [u (second val)]) - (hash-table-put! hashed-units cell-loc u))))) - - (define (lookup-formula-text cell-sym all-formula-texts) - (let ([entry (assq cell-sym all-formula-texts)]) - (and entry (cadr entry)))) - - (define (identify-matrices str) - (map (lambda (range) - (map (lambda (cell) - (string->symbol cell)) - (split-string range #\:))) - (split-string (to-lower str) #\,))) - - (define (matrix-row-units M row hashed-units) - (let ([row-cells (get-range-cells (first-cell-in-row M row) - (last-cell-in-row M row))]) - (map (lambda (cellref) - (cond ((in-hash? hashed-units cellref) - (hash-table-get hashed-units cellref)) - (else (empty-unit)))) - row-cells))) - - (define (matrix-row-syms M row hashed-units hashed-vars) - (let ([row-cells (get-range-cells (first-cell-in-row M row) - (last-cell-in-row M row))]) - (foldl (lambda (cellref syms-constraints) - (let ([sym (gen-beta-var)] - [syms (first syms-constraints)] - [constraints (second syms-constraints)]) - (cond [(in-hash? hashed-units cellref) - (let ([u (hash-table-get hashed-units cellref)]) - (cond [(in-hash? hashed-vars u) (list (cons u syms) constraints)] - [else (list (cons sym syms) - (cons (list '= sym u) constraints))]))] - [else (list (cons sym syms) - (cons (list '= sym (empty-unit)) constraints))]))) - row-cells))) - - (define (first-cell-in-row M row) - (let ([xy (cellref->numbers (car M))]) - (numbers->cellref (list (sub1 (car xy)) (+ (cadr xy) row))))) - - (define (last-cell-in-row M row) - (let ([xy-upper (cellref->numbers (car M))] - [xy-lower (cellref->numbers (cadr M))]) - (numbers->cellref (list (sub1 (car xy-lower)) (+ (cadr xy-upper) row))))) - - (define (matrix-col-units M col hashed-units) - (let ([col-cells (get-range-cells (first-cell-in-col M col) - (last-cell-in-col M col))]) - (map (lambda (cellref) - (cond ((in-hash? hashed-units cellref) - (hash-table-get hashed-units cellref)) - (else (empty-unit)))) - col-cells))) - - (define (matrix-col-syms M col hashed-units hashed-vars) - (let ([col-cells (get-range-cells (first-cell-in-col M col) - (last-cell-in-col M col))]) - (foldl (lambda (cellref syms-constraints) - (let ([sym (gen-beta-var)] - [syms (first syms-constraints)] - [constraints (second syms-constraints)]) - (cond [(in-hash? hashed-units cellref) - (let ([u (hash-table-get hashed-units cellref)]) - (cond [(in-hash? hashed-vars u) (list (cons u syms) constraints)] - [else (list (cons sym syms) - (cons (list '= sym u) constraints))]))] - [else (list (cons sym syms) - (cons (list '= sym (empty-unit)) constraints))]))) - col-cells))) - - (define (first-cell-in-col M col) - (let ([xy (cellref->numbers (car M))]) - (numbers->cellref (list (+ (sub1 (car xy)) col) (cadr xy))))) - - (define (last-cell-in-col M col) - (let ([xy-upper (cellref->numbers (car M))] - [xy-lower (cellref->numbers (cadr M))]) - (numbers->cellref (list (+ (sub1 (car xy-upper)) col) (cadr xy-lower))))) - - (define (split-large-args l) - (let ([reversed-l (reverse l)]) - (list (list (first reversed-l)) (reverse (rest reversed-l))))) - - (define (split-circular-non-circular all-formulas) - (let ([visited (make-hash-table)]) - (letrec ([is-circular? - (lambda (f fs) - (ormap - (lambda (dep) - (cond [(in-hash? visited dep) - (let ([circularity (hash-table-get visited dep)]) - (cond [(eq? 'circular circularity) #t] - [else #f]))] - [else - (let ([circularity - (or (memq dep fs) - (let ([dep_f (assq dep all-formulas)]) - (and dep_f - (is-circular? dep_f (cons dep fs)))))]) - (cond [circularity - (hash-table-put! visited dep 'circular)] - [else - (hash-table-put! visited dep 'non-circular)]) - circularity)])) - (formula-dependencies (cadr f))))]) - (split-list (reverse all-formulas) (lambda (f) (is-circular? f (list (car f)))))))) - - (define (computation-errors hashed-units all-formula-texts all-formulas) - (filter - (lambda (l) (not (empty? l))) - (hash-table-map - hashed-units - (lambda (cell unit) - (if (is-error-unit? unit) - (let ([o (open-output-string)]) - (cond [(equal? 'error/propagated (first (first unit))) - (fprintf o "ERROR propagated from cell: ~a" - (second (first unit)))] - [else - (fprintf o "ERROR computed: ~n~a " (car (first unit))) - (fprintf o ", cell formula: ~a~n" - (lookup-formula-text cell all-formula-texts))]) - (list cell - unit - (get-output-string o) - (formula-dependencies (cadr (assq cell all-formulas))))) - empty))))) - - (define (mismatch-errors hashed-units all-units all-formula-texts all-formulas) - (foldl - (lambda (annot mismatches) - (let* ([cell (car annot)] - [actual (hash-table-get hashed-units cell)]) - (cond [(not (or (is-error-unit? actual) - (empty-unit? (cadr annot)) - (equal? actual (cadr annot)))) - (let ([o (open-output-string)]) - (fprintf o "MISMATCH computed:~n~a " (unit-pp actual)) - (fprintf o "cell-formula: ~a~n" (lookup-formula-text cell all-formula-texts)) - (cons (list cell - actual - (get-output-string o) - (formula-dependencies (cadr (assq cell all-formulas)))) - mismatches))] - [else mismatches]))) - empty - all-units)) - - (define (unit-pp unit) - (cond [(empty-unit? unit) "()"] - [else - (let* ([unit-top-bottom (split-list unit (lambda (u) (> (second u) 0)))] - [unit-top (first unit-top-bottom)] - [unit-bottom (map (lambda (u) (list (first u) (- 0 (second u)))) - (second unit-top-bottom))] - [to-string - (lambda (unit) - (foldl - (lambda (u visited) - (string-append - (cond [(> (second u) 1) - (string-append "-" (symbol->string (first u)) - "^" (number->string (second u)))] - [else - (string-append "-" (symbol->string (first u)))]) - visited)) - "" - unit))] - [top-string (to-string unit-top)] - [bottom-string (to-string unit-bottom)] - [top-len (string-length top-string)] - [bottom-len (string-length bottom-string)]) - (cond [(and (= 0 top-len) (= 0 bottom-len)) ""] - [(= 0 top-len) (substring bottom-string 1 bottom-len)] - [(= 0 bottom-len) (substring top-string 1 top-len)] - [else - (string-append (substring top-string 1 top-len) "/(" - (substring bottom-string 1 bottom-len) ")")]))])) - ) - diff --git a/collects/xelda/private/xelda-com.ss b/collects/xelda/private/xelda-com.ss deleted file mode 100644 index 0924fad01c..0000000000 --- a/collects/xelda/private/xelda-com.ss +++ /dev/null @@ -1,225 +0,0 @@ -(module xelda-com mzscheme - - (require (lib "mysterx.ss" "mysterx")) - (require mzlib/list) - (require mzlib/class) - - (require "xl-util.ss") - - (provide load-xl-file ;; filename -> void - set-gui! ;; gui -> void - ;; gui is an instance of the class %xelda-frame% in xelda.ss - close-xl-workbook ;; void -> void - clear-cell-precedents ;; cellref -> void - ;; cellref as a symbol representing a cell (ex: 'a1 for cell A1) - get-cell-text ;; cellref -> string - get-cell-value ;; cellref -> cell-value - get-cell-formula ;; cellref -> string - get-cell-name ;; cellref -> string - get-cell-row-col ;; cellref -> (N , N) - ;; cell-value is defined as per Excel specifications for "Value" property - get-cell-color ;; cellref -> color - set-cell-color! ;; cellref color -> void - get-cell-comment ;; cellref -> string - set-cell-comment! ;; cellref string -> void - delete-cell-comment! ;; cellref -> void - iterate-over-worksheet ;; (cellref -> V) (V -> bool) -> (Listof (cellref , V)) - work-sheet-enabled? ;; void -> bool - ) - - (define *cached-ws* empty) - (define *wb* #f) - (define *ws* #f) - (define *excel-progid* "Excel.Application") - (define *xl* (cci/progid *excel-progid*)) - (define *gui* #f) - - (define (range-from-coords row col) - (string-append (number->cell-alpha (sub1 col)) - (number->string row))) - - (define (set-gui! gui) (set! *gui* gui)) - - (define (work-sheet-enabled?) - (not (equal? *ws* #f))) - - (define (iterate-over-worksheet f pred?) - (when (empty? *cached-ws*) - (let* ([ur (com-get-property *ws* "UsedRange")] - [cells (com-get-property ur "Cells")] - [first-row (com-get-property cells "Row")] - [first-col (com-get-property cells "Column")] - [num-rows (com-get-property cells "Rows" "Count")] - [num-cols (com-get-property cells "Columns" "Count")] - [last-row (sub1 (+ first-row num-rows))] - [last-col (sub1 (+ first-col num-cols))]) - (let row-loop ([curr-row first-row] - [row-results null]) - (if (> curr-row last-row) - (set! *cached-ws* row-results) - (let col-loop ([curr-col first-col] - [col-results null]) - (if (> curr-col last-col) - (row-loop (add1 curr-row) - (append col-results - row-results)) - (col-loop (add1 curr-col) - (cons (string->symbol (range-from-coords curr-row curr-col)) - col-results)))))))) - (foldl (lambda (cached-cell selected-cells) - (let ([cell-content (f cached-cell)]) - (if (pred? cell-content) - (cons (list cached-cell cell-content) selected-cells) - selected-cells))) - empty *cached-ws*)) - - (define (get-cell-name cell) - (with-handlers - ([void (lambda _ "")]) - (com-get-property (com-get-property (cellref->rng cell) "Name") "Name"))) - - (define (get-cell-formula cell) - (com-get-property (cellref->rng cell) "Formula")) - - (define (get-cell-row-col cell) - (let* ([rng (cellref->rng cell)] - [M (com-get-property rng "CurrentArray")] - [first-row (com-get-property M "Row")] - [first-col (com-get-property M "Column")] - [cell-row (com-get-property rng "Row")] - [cell-col (com-get-property rng "Column")]) - (list (- cell-row first-row) (- cell-col first-col)))) - - - (define (set-cell-comment! cell comment-text) - (let* ([rng (cellref->rng cell)] - [comment-obj (com-get-property rng "Comment")]) - (with-handlers ([void (lambda _ "")]) - (com-invoke comment-obj "Delete")) - (com-invoke rng "AddComment" (format "~a" comment-text)))) - - (define (delete-cell-comment! cell) - (let* ([rng (cellref->rng cell)] - [comment-obj (com-get-property rng "Comment")]) - (with-handlers ([void (lambda _ "")]) - (com-invoke comment-obj "Delete")))) - - (define (get-cell-comment cell) - (with-handlers ([void (lambda _ "")]) - (com-invoke (com-get-property (cellref->rng cell) "Comment") "Text"))) - - (define (get-cell-color cellref) - (com-get-property (com-get-property (cellref->rng cellref) "Interior") "Color")) - - (define (set-cell-color! cellref rgb) - (let ([rng (cellref->rng cellref)]) - (com-set-property! - (com-get-property rng "Interior") - "Color" rgb) - (com-set-property! - (com-get-property rng "Borders") - "Color" 11842740))) - - (define (get-cell-text cellref) - (com-get-property (cellref->rng cellref) "Text")) - - (define (get-cell-value cellref) - (com-get-property (cellref->rng cellref) "Value")) - - (define (get-cell row col) - (com-get-property - *ws* - `("Range" ,(range-from-coords row col)))) - - (define (cellref->rng cell) - (let ([xy (cellref->numbers cell)]) - (get-cell (cadr xy) (car xy)))) - - (define (clear-cell-precedents cellref) - (com-invoke (cellref->rng cellref) "ShowPrecedents" #t)) - - (define (open-xl-workbook xl fname) - (let ([wbs (com-get-property xl "Workbooks")]) - (with-handlers - (((lambda (_) #t) (lambda (_) #f))) - (com-invoke wbs "Open" fname)))) - - (define (close-xl-workbook) - (let ([wbs (com-get-property *xl* "Workbooks")]) - (with-handlers - (((lambda (_) #t) (lambda (_) #f))) - (com-invoke wbs "Close")))) - - (define (add-xl-workbook xl) - (let* ([wbs (com-get-property xl "Workbooks")]) - (com-invoke wbs "Add"))) - - (define (load-xl-file filename) - (set! *cached-ws* empty) - (com-set-property! *xl* "Visible" #t) - (set! *wb* (open-xl-workbook *xl* filename)) - (set! *ws* (com-get-property *wb* "ActiveSheet")) - - ;; - ;; Event handlers - ;; - (com-register-event-handler - *wb* "SheetActivate" - (lambda (wb-arg) - (when *ws* - (send *gui* unmark-errors) - (com-unregister-event-handler *ws* "SelectionChange")) - (set! *ws* (com-get-property *wb* "ActiveSheet")) - (set! *cached-ws* empty) - (com-register-event-handler - *ws* "SelectionChange" - (lambda (rng) - (when (send *gui* file-opened?) - (let* ([row (com-get-property rng "Row")] - [col (com-get-property rng "Column")] - [rows (com-get-property rng "Rows" "Count")] - [cols (com-get-property rng "Columns" "Count")] - [left-top (numbers->cellref (list (sub1 col) row))] - [right-bottom (numbers->cellref (list (- (+ col cols) 2) - (sub1 (+ row rows))))]) - (send *gui* erase-cell-selections) - (send *gui* set-cell-selections (format "~a:~a" left-top right-bottom)))))))) - - (com-register-event-handler - *ws* "SelectionChange" - (lambda (rng) - (when (send *gui* file-opened?) - (let* ([row (com-get-property rng "Row")] - [col (com-get-property rng "Column")] - [rows (com-get-property rng "Rows" "Count")] - [cols (com-get-property rng "Columns" "Count")] - [left-top (numbers->cellref (list (sub1 col) row))] - [right-bottom (numbers->cellref (list (- (+ col cols) 2) - (sub1 (+ row rows))))]) - (send *gui* erase-cell-selections) - (send *gui* set-cell-selections (format "~a:~a" left-top right-bottom)))))) - - (com-register-event-handler - *wb* "BeforeClose" - (lambda (cancel) (when (send *gui* file-opened?) (send *gui* close-frame!))))) - - (com-register-event-handler - *xl* "SheetBeforeRightClick" - (lambda (ws rng b) - (let* ([row (com-get-property rng "Row")] - [col (com-get-property rng "Column")] - [cell-ref (numbers->cellref (list (sub1 col) row))]) - (when (send *gui* error-cell? cell-ref) - (set-box! b #t) - (let ([dependencies (send *gui* get-error-cell-dependencies cell-ref)]) - (if (eq? (send *gui* get-error-cell-state cell-ref) 'off) - (begin - (send *gui* set-error-cell-state cell-ref 'on) - (send *gui* color-dependents dependencies 'off) - (com-invoke rng "ShowPrecedents" #t)) - (begin - (send *gui* set-error-cell-state cell-ref 'off) - (send *gui* color-dependents dependencies 'on) - (com-invoke rng "ShowPrecedents"))))))))) - - diff --git a/collects/xelda/private/xelda-lib.ss b/collects/xelda/private/xelda-lib.ss deleted file mode 100644 index b6b2de4330..0000000000 --- a/collects/xelda/private/xelda-lib.ss +++ /dev/null @@ -1,150 +0,0 @@ -(module xelda-lib mzscheme - - (require mzlib/list) - - (provide - average - gen-equal-units - gen-mult-units - gen-div-units - gen-exp-units - split-list - check-empty-units - check-equal-units - is-error-unit? - empty-unit? - empty-unit - canonicalize-units - verify-equal-units) - - (define (empty-unit) (list (list 'empty_unit 1))) - - (define (canonicalize-units us) - (filter (lambda (u) (not (zero? (cadr u)))) - (sort us (lambda (u1 u2) - (string<=? (symbol->string (car u1)) - (symbol->string (car u2))))))) - - (define (empty-unit? u) - (and (= (length u) 1) - (eq? (car (first u)) 'empty_unit))) - - (define (split-list lst p?) - (let loop ([lst lst] - [yes null] - [no null]) - (if (null? lst) - (list (reverse yes) (reverse no)) - (if (p? (car lst)) - (loop (cdr lst) (cons (car lst) yes) no) - (loop (cdr lst) yes (cons (car lst) no)))))) - - (define (average . ns) - (/ (apply + ns) (length ns))) - - (define (gen-equal-units . us) - (let ([u1 (car us)]) - (if (andmap (lambda (u) (equal? u u1)) - (cdr us)) - u1 - '((error/equality 1))))) - - (define (is-error-unit? u) - (if (and (list? u) (pair? (first u))) - (let ([str (symbol->string (car (first u)))]) - (cond - ((and (> (string-length str) 6) - (string=? (substring str 0 6) "error/")) #t) - (else #f))) - #f)) - - (define (check-equal-units unts sym) - (let* ([us (map (lambda (_us) - (map (lambda (u) - (cond ((eq? (car u) 'empty_unit) - (list 'empty_unit 1)) - (else u))) _us)) unts)] - [base-unit (first us)] - [err-us (filter (lambda (u) (is-error-unit? u)) us)]) - (if (not (empty? err-us)) - (if (eq? sym (second (first (first err-us)))) - (first err-us) - (list (list 'error/propagated (second (first (first err-us)))))) - (if (andmap (lambda (u) (equal? u base-unit)) us) - base-unit - (list (list 'error/equality sym)))))) - - (define (verify-equal-units cell-name u1 u2) - (if (equal? u1 u2) - (printf "Verified units for cell ~a~n" cell-name) - (printf (string-append - "Units problem with cell ~a:~n" - "Cell annotated with ~a, formula yields ~a~n") - cell-name u1 u2))) - - (define (gen-mult-units u1 u2 sym) - (cond [(is-error-unit? u1) - (cond [(eq? sym (second (first u1))) u1] - [else (list (list 'error/propagated - (second (first u1))))])] - [(is-error-unit? u2) - (cond [(eq? sym (second (first u2))) u2] - [else (list (list 'error/propagated - (second (first u2))))])] - [(empty-unit? u1) u2] - [(empty-unit? u2) u1] - [else - (let ([raw-us (append u1 u2)]) - (let loop ([new-us raw-us] - [result null]) - (if (null? new-us) - (canonicalize-units result) - (let* ([u (car new-us)] - [u-name (car u)] - [u-exp (cadr u)] - [u-and-non-u - (split-list (cdr new-us) - (lambda (x) - (eq? (car x) u-name)))] - [new-u-exp (+ u-exp - (apply + (map cadr (car u-and-non-u))))] - [non-u (cadr u-and-non-u)]) - (loop non-u (cons (list u-name new-u-exp) result))))))])) - - (define (gen-div-units u1 u2 sym) - (cond [(is-error-unit? u1) - (cond [(eq? sym (second (first u1))) u1] - [else (list (list 'error/propagated - (second (first u1))))])] - [(is-error-unit? u2) - (cond [(eq? sym (second (first u2))) u2] - [else (list (list 'error/propagated - (second (first u2))))])] - [(empty-unit? u2) u1] - [else - (gen-mult-units u1 (map (lambda (u) - (let ([u-name (car u)] - [u-exp (cadr u)]) - (list u-name (- 0 u-exp)))) u2) sym)])) - - (define (gen-exp-units u exp sym) - (cond [(is-error-unit? u) - (cond [(eq? sym (second (first u))) u] - [else (list (list 'error/propagated (second (first u))))])] - [else - (if (not (integer? exp)) - '((error/exponentiation sym)) - (cond [(empty-unit? u) u] - [else - (map (lambda (u_) - (let ([u-name (car u_)] - [u-exp (cadr u_)]) - (list u-name (inexact->exact - (* exp u-exp))))) - u)]))])) - - (define (check-empty-units . us) - (if (andmap null? us) - null - '((error/empty-unit 1))))) - diff --git a/collects/xelda/private/xl-util.ss b/collects/xelda/private/xl-util.ss deleted file mode 100644 index ea25e9aff8..0000000000 --- a/collects/xelda/private/xl-util.ss +++ /dev/null @@ -1,188 +0,0 @@ -(module xl-util mzscheme - (require mzlib/list) - - (provide - cell-alpha->number - number->cell-alpha - get-range-cells - numbers->cellref - cellref->numbers - split-string - in-list? - make-equiv-class - find-rep - union - to-lower - show-constraints - all-hashed-values - in-hash? - init-hash - left-of - top-of) - - (define (show-constraints constraints) - (for-each (lambda (c) (printf "constraint: ~a~n" c)) constraints)) - - (define (in-hash? ht v) - (not (not (hash-table-get ht v (lambda () #f))))) - - (define (init-hash ht l) - (if (not (empty? l)) - (begin - (let ([cell-name (car (first l))] - [u (cadr (first l))]) - (if (not (in-hash? ht cell-name)) - (hash-table-put! ht cell-name u))) - (init-hash ht (rest l))))) - - (define (all-hashed-values ht) - (hash-table-for-each ht - (lambda (key val) - (printf "Key:~a -> Value:~a~n" key val)))) - - (define (make-equiv-class a) (list a)) - - (define (find-rep equiv-class) - (let ([rep (last-pair equiv-class)]) - (when (not (eq? equiv-class rep)) - (set-cdr! equiv-class rep)) - rep)) - - (define (union equiv-class1 equiv-class2) - (let ([rep1 (find-rep equiv-class1)] - [rep2 (find-rep equiv-class2)]) - (unless (eq? rep1 rep2) - (set-cdr! rep2 rep1)) - rep1)) - - (define (in-list? e l) - (cond [(empty? l) #f] - [(equal? e (first l)) #t] - [else (in-list? e (rest l))])) - - (define (to-lower str) - (letrec ([loop (lambda (l) - (cond - ((empty? l) empty) - ((char-upper-case? (first l)) - (cons (integer->char - (+ (- (char->integer (first l)) - (char->integer #\A)) - (char->integer #\a))) - (loop (rest l)))) - (else (cons (first l) (loop (rest l))))))]) - (list->string (loop (string->list str))))) - - (define (split-string str c) - (letrec ([loop (lambda (i first max c) - (cond - ((>= first max) empty) - ((>= i max) - (list (substring str first max))) - ((eq? (string-ref str i) c) - (cons - (substring str first i) - (loop (add1 i) (add1 i) max c))) - (else (loop (add1 i) first max c))))]) - (loop 0 0 (string-length str) c))) - - ; #\a = 0, #\b = 1, etc. - (define (letter->number c) - (- (char->integer c) 97)) ; #\a - (define (number->letter n) - (integer->char (+ n 97))) - - ; "a" = 0, "b" = 1, ... , "aa" = 26, ... , "ba" = 52, ... - (define (cell-alpha->number s) - (let ([len (string-length s)]) - (if (= len 1) - (letter->number (string-ref s 0)) - (+ (* 26 (add1 (letter->number (string-ref s 0)))) - (letter->number (string-ref s 1)))))) - (define (number->cell-alpha n) - (if (< n 26) - (string (number->letter n)) - (string-append - (string (number->letter (sub1 (quotient n 26)))) - (string (number->letter (modulo n 26)))))) - - - ; given a cell address as a symbol, such as 'D5 - ; returns the alpha and numeric pieces as a string and a number - (define (get-cell-components csym) - (let* ([c (symbol->string csym)] - [len (string-length c)]) - (if (char-numeric? (string-ref c 1)) - (values (substring c 0 1) - (string->number (substring c 1 len))) - (values (substring c 0 2) - (string->number (substring c 2 len)))))) - - ; from pair of numbers representing a cell address in its alpha - ; and numeric components, return symbol - ; (1 1) = A1, ... , (27 0) = AA0, ... - (define (numbers->cellref ns) - (let ([alpha-part (car ns)] - [num-part (cadr ns)]) - (string->symbol - (string-append - (number->cell-alpha alpha-part) - (number->string num-part))))) - (define (cellref->numbers cell) - (letrec ([iter (lambda (l x y) - (cond - ((empty? l) (list x y)) - (else - (let ([c (first l)]) - (cond - ((char-numeric? c) - (iter (rest l) x (+ (* 10 y) - (- (char->integer c) - (char->integer #\0))))) - (else - (iter (rest l) (+ (* 26 x) - (- (char->integer c) - (char->integer #\a)) 1) y)))))))]) - (iter (string->list (symbol->string cell)) 0 0))) - - (define (left-of loc) - (let* ([xy (cellref->numbers loc)] - [x (- (car xy) 2)] - [y (cadr xy)]) - (numbers->cellref (list x y)))) - - (define (top-of loc) - (let* ([xy (cellref->numbers loc)] - [x (sub1 (car xy))] - [y (sub1 (cadr xy))]) - (numbers->cellref (list x y)))) - - ; given two corner cells (as symbols), return list of symbols - ; for all contained cells - (define (get-range-cells c1 c2) - (let*-values - ([(a1 n1) (get-cell-components c1)] - [(a2 n2) (get-cell-components c2)] - [(alow ahigh) - (if (stringnumber alow) - (cell-alpha->number ahigh))]) - (let oloop ([curr-a numalow] - [oresult null]) - (if (> curr-a numahigh) - (map numbers->cellref oresult) - (let iloop ([curr-n nlow] - [iresult null]) - (if (> curr-n nhigh) - (oloop (add1 curr-a) - (append iresult oresult)) - (iloop (add1 curr-n) - (cons (list curr-a curr-n) iresult))))))))) - diff --git a/collects/xelda/units.xls b/collects/xelda/units.xls deleted file mode 100644 index 9c2ed0a202..0000000000 Binary files a/collects/xelda/units.xls and /dev/null differ diff --git a/collects/xelda/xelda.ss b/collects/xelda/xelda.ss deleted file mode 100644 index d63dbaa189..0000000000 --- a/collects/xelda/xelda.ss +++ /dev/null @@ -1,423 +0,0 @@ -(module xelda mzscheme - (require mzlib/class) - (require mzlib/list) - (require mred) - - (require "private/xelda-com.ss") - (require "private/xelda-checker.ss") - (require "private/parser.ss") - (require "private/xl-util.ss") - (require "private/formula.ss") - - (define-struct dependent (count orig-color) (make-inspector)) - - (define xelda-frame% - (class frame% - (field - [bad-format-cells empty] - [bad-format-cells-colors #f] - [colored-dependents #f] - [error-cells #f] - [file-checked #f] - [filename #f] - [file-opened #f] - [parser (make-parser empty)] - [status-text-editor #f] - [range-text-editor #f] - [status-panel #f] - [status-text #f] - [status-message #f] - [assign-panel #f] - [assign-button #f] - [range-text #f] - [units-text #f] - [buttons-panel #f] - [load-button #f] - [quit-button #f] - [close-button #f] - [clear-button #f] - [check-button #f]) - (public* - [error-cell? (lambda (cell) (and (hash-table? error-cells) - (in-hash? error-cells cell)))] - [get-error-cell-dependencies (lambda (cell) (second (hash-table-get error-cells cell)))] - [get-error-cell-state (lambda (cell) (first (hash-table-get error-cells cell)))] - [set-error-cell-state - (lambda (cell state) - (hash-table-put! error-cells cell - (list state (second (hash-table-get error-cells cell)))))] - [set-cell-selections (lambda (str) (send range-text-editor insert str))] - [erase-cell-selections (lambda () (send range-text-editor erase))] - [file-opened? (lambda () file-opened)] - [set-status (lambda (str) - (send status-text-editor erase) - (send status-text-editor insert str))] - [update-status (lambda (str) (send status-text-editor insert str))] - [next-update-status (lambda (str) (update-status (format "done~n~a.... " str)))] - [set-bad-format-cells (lambda (bad-cells) (set! bad-format-cells bad-cells))] - [set-computation-errors - (lambda (errors) - (update-status (format "+++ERROR REPORTING+++~n")) - (set! error-cells (make-hash-table)) - (for-each - (lambda (cell-unit-str-dependencies) - (let ([cell (first cell-unit-str-dependencies)] - [unit (second cell-unit-str-dependencies)] - [str (third cell-unit-str-dependencies)] - [dependencies (fourth cell-unit-str-dependencies)]) - (cond [(equal? 'error/propagated (first (first unit))) - (set-cell-color! cell (rgb 209 35 238)) - (update-status - (format "Cell ~a error propagation from cell~a~n" - cell - (second (first unit))))] - [else - (set-cell-color! cell (rgb 255 255 51)) - (update-status (format "Cell ~a error in computed units!~n" cell))]) - (append-cell-comment! cell str) - (hash-table-put! error-cells cell (list 'on dependencies)))) - errors))] - [set-mismatch-errors - (lambda (errors) - (for-each - (lambda (cell-actual-str-dependencies) - (let ([cell (first cell-actual-str-dependencies)] - [actual (second cell-actual-str-dependencies)] - [str (third cell-actual-str-dependencies)] - [dependencies (fourth cell-actual-str-dependencies)]) - (set-cell-color! cell (rgb 255 153 51)) - (append-cell-comment! cell str) - (hash-table-put! error-cells cell (list 'on dependencies)) - (update-status - (format "Cell ~a mismatch between annotated and computed units!~n" - cell)))) - errors))] - [close-frame! - (lambda() - (set! file-opened #f) - (set-status (format "Load Excel file~n")) - (send load-button enable #t) - (send close-button enable #f) - (send check-button enable #f) - (send clear-button enable #f) - (send assign-button enable #f) - (send range-text enable #f) - (send units-text enable #f) - (close-xl-workbook))] - [color-dependents - (lambda (l action) - (when (not (empty? l)) - (set-cell-color! (first l) (get-dependent-color (first l) action)) - (color-dependents (rest l) action)))] - [unmark-errors - (lambda () - (when (hash-table? error-cells) - (let ([orig-col (get-cell-color 'a1)]) - (hash-table-for-each - error-cells - (lambda (k v) - (let ([state (first v)] - [dependencies (second v)]) - (when (eq? state 'off) - (color-dependents dependencies 'off) - (clear-cell-precedents k)) - (let ([orig (original-comment (get-cell-comment k))]) - (cond - ((and (>= (string-length orig) 2) - (string=? "()" (substring orig 0 2))) - (delete-cell-comment! k)) - (else (set-cell-comment! k orig)))) - (set-cell-color! k orig-col)))) - (set! error-cells #f) - (set! colored-dependents #f))))] - [reset-frame! - (lambda() - (for-each (lambda (panel) - (when panel (send panel show #f))) - (list status-panel buttons-panel)) - (set! buttons-panel - (instantiate horizontal-panel% () - (parent this) - (stretchable-height #f) - (vert-margin 2) - (alignment '(center center)))) - (set! status-panel - (instantiate vertical-panel% () - (parent this) - (border 5) - (horiz-margin 5) - (vert-margin 10) - (stretchable-height #t) - (style '(border)))) - (set! assign-panel - (instantiate vertical-panel% () - (parent this) - (stretchable-height #f) - (style '(border)) - (border 5) - (spacing 3) - (horiz-margin 5) - (vert-margin 5) - (alignment '(center center)))) - (set! status-message - (instantiate message% () - (label "XeLda Status:") - (parent status-panel))) - (set! status-text - (instantiate text-field% () - (label #f) - (init-value (format "Ready to load Excel file~n")) - (parent status-panel) - (style (list 'multiple)) - (stretchable-height #t) - (enabled #t) - (callback (lambda (txt-fld cntrl-evnt) ())))) - (set! status-text-editor (send status-text get-editor)) - (set! range-text - (instantiate text-field% () - (label "Cell(s) Range(s):") - (parent assign-panel) - (enabled #f) - (callback (lambda (txg-fld cntrl-evnt) ())))) - (set! range-text-editor (send range-text get-editor)) - (set! units-text - (instantiate text-field% () - (label " Cell(s) Units:") - (parent assign-panel) - (enabled #f) - (callback (lambda (txt-fld cntrl-evnt) ())))) - (set! assign-button - (instantiate button% () - (label "Assign Units") - (parent assign-panel) - (enabled #f) - (callback - (lambda (b env) - (let* ([range-editor (send range-text get-editor)] - [units-editor (send units-text get-editor)] - [range-txt (send range-editor get-text)] - [units-txt (send units-editor get-text)] - [unit-list (get-ranges-from-txt range-txt parser)] - [unit (get-units-from-txt units-txt)]) - (cond - ((empty? unit) - (message-box "Invalid Input" - "Improper unit format" - this - '(ok))) - ((empty? unit-list) - (message-box "Invalid Input" - "Improper range format" - this - '(ok))) - (else - (send range-editor erase) - (send units-editor erase) - (for-each (lambda (us) - (for-each (lambda (c) - (set-cell-comment! c units-txt)) - us)) - unit-list)))))))) - (set! load-button - (instantiate button% () - (label "Load File") - (parent buttons-panel) - (callback (lambda (b ev) - (let ([file-name (get-filename)]) - (when file-name - (set! file-checked #f) - (set! file-opened #t) - (set! filename file-name) - (update-status (format "Loaded file: ~a~n" filename)) - (open-frame!))))))) - (set! close-button - (instantiate button% () - (label "Close File") - (parent buttons-panel) - (enabled #f) - (callback (lambda (b ev) - (close-frame!))))) - (set! check-button - (instantiate button% () - (label "Analyze") - (parent buttons-panel) - (enabled #f) - (callback (lambda (b ev) - (send quit-button enable #f) - (send close-button enable #f) - (send clear-button enable #f) - (send check-button enable #f) - (send assign-button enable #f) - (send units-text enable #f) - (send range-text enable #f) - (thread (lambda() - (time - (begin - (when file-checked (unmark-errors)) - (unit-check-xl-file) - (set! file-checked #t) - (send clear-button enable #t) - (send check-button enable #t) - (send close-button enable #t) - (send assign-button enable #t) - (send units-text enable #t) - (send range-text enable #t) - (send quit-button enable #t))))))))) - (set! clear-button - (instantiate button% () - (label "Clear") - (parent buttons-panel) - (enabled #f) - (callback (lambda (b ev) - (unmark-errors) - (clear-all-precedents))))) - (set! quit-button - (instantiate button% () - (label "Quit Xelda") - (parent buttons-panel) - (callback (lambda (b ev) - (when file-opened (close-xl-workbook)) - (send this show #f))))))]) - (private* - [unit-check-xl-file - (lambda () - (when (not (empty? bad-format-cells)) - (clear-bad-format-cells)) - (cond [(empty? bad-format-cells) - (unit-check this) - (set! colored-dependents (make-hash-table)) - (update-status (format "+++XeLda DONE!+++~n"))] - [else (mark-bad-format-cells)]))] - [clear-bad-format-cells - (lambda () - (for-each - (lambda (bad-cell-with-unit) - (let* ([bad-cell (first bad-cell-with-unit)] - [bad-unit (second bad-cell-with-unit)] - [orig-col (hash-table-get bad-format-cells-colors bad-cell)]) - (set-cell-color! bad-cell orig-col))) - bad-format-cells) - (set! bad-format-cells-colors #f) - (set! bad-format-cells empty))] - [mark-bad-format-cells - (lambda () - (when (not (empty? bad-format-cells)) - (set! bad-format-cells-colors (make-hash-table)) - (update-status - (format "+++PREPROCESSING ERROR++~nImproper unit format for the following cells:~n")) - (for-each - (lambda (bad-cell-with-unit) - (let* ([bad-cell (first bad-cell-with-unit)] - [bad-unit (second bad-cell-with-unit)] - [orig-col (get-cell-color bad-cell)]) - (update-status (format "cell: ~a - Improper unit format~n" bad-cell)) - (hash-table-put! bad-format-cells-colors bad-cell orig-col) - (set-cell-color! bad-cell (rgb 120 170 120)))) - bad-format-cells)))] - [clear-all-precedents - (lambda () - (when (hash-table? error-cells) - (hash-table-for-each - error-cells - (lambda (cell v) - (let ([state (first v)] - [dependencies (second v)]) - (when (eq? state 'off) - (hash-table-put! error-cells cell (list 'on dependencies)) - (color-dependents dependencies 'off) - (clear-cell-precedents cell)))))))] - [get-dependent-color - (lambda (loc action) - (if (eq? action 'on) - (begin - (if (in-hash? colored-dependents loc) - (let ([dep (hash-table-get colored-dependents loc)]) - (hash-table-put! colored-dependents loc - (make-dependent (+ (dependent-count dep) 1) - (dependent-orig-color dep)))) - (hash-table-put! colored-dependents loc - (make-dependent - 0 - (get-cell-color loc)))) - (rgb 250 0 0)) - (let ([dep (hash-table-get colored-dependents loc)]) - (if (= 0 (dependent-count dep)) - (begin - (hash-table-remove! colored-dependents loc) - (dependent-orig-color dep)) - (begin - (hash-table-put! colored-dependents loc - (make-dependent (sub1 (dependent-count dep)) - (dependent-orig-color dep))) - (rgb 250 0 0))))))] - [open-frame! - (lambda() - (send load-button enable #f) - (send close-button enable #t) - (send check-button enable #t) - (send assign-button enable #t) - (send range-text enable #t) - (send units-text enable #t) - (load-xl-file filename))]) - (super-instantiate()) - (reset-frame!))) - - (define *gui* - (instantiate xelda-frame% () - (label "XeLda") - (width 400) - (height 550))) - - (send *gui* center) - (send *gui* show #t) - (set-gui! *gui*) - - (define (get-filename) - (get-file ".xls files" - *gui* - (collection-path "xelda") - #f - "xls" - '() - '(("Excel Files" "*.xls")))) - - (define (rgb r g b) - (+ (* 65536 b) (* 256 g) r)) - - (define (original-comment comment) - (letrec ([loop (lambda (str i max) - (cond [(= i max) str] - [(equal? #\; (string-ref str i)) (substring str 0 (sub1 i))] - [else (loop str (+ i 1) max)]))]) - (loop comment 0 (string-length comment)))) - - (define (append-cell-comment! cellref scheme-comment) - (let ([orig-comment (get-cell-comment cellref)]) - (cond [(string=? "" orig-comment) - (set-cell-comment! cellref (format "()~n;; ~a" scheme-comment))] - [else - (set-cell-comment! cellref (format "~a~n;; ~a" orig-comment scheme-comment))]))) - - (define (get-ranges-from-txt str parser) - (let* ([s (list->string (filter (lambda (c) (not (char-whitespace? c))) - (string->list str)))] - [ranges-txt (split-string s #\,)] - [ranges (map (lambda (r) (split-string r #\:)) ranges-txt)] - [valid-ranges (filter (lambda (r) (not (empty? r))) - (map (lambda (r) - (filter (lambda (c) - (cell-ref? (call-parser parser c))) - r)) - ranges))]) - (map (lambda (r) - (cond ((= 2 (length r)) (get-range-cells (first r) (second r))) - (else r))) - (map (lambda (r) - (map (lambda (c) (string->symbol (to-lower c))) r)) - valid-ranges)))) - - (define (get-units-from-txt str) - (with-handlers ([void (lambda _ '())]) - (parse-unit str))) - ) -