The xelda collection does not compile.
svn: r8794
This commit is contained in:
Eli Barzilay
parent
44ee09193e
commit
e5473ecae2
Binary file not shown.
Binary file not shown.
|
|
@ -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)))
|
||||
|
|
@ -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))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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")))))))))
|
||||
|
||||
|
||||
|
|
@ -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)))))
|
||||
|
||||
|
|
@ -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 (string<? a1 a2)
|
||||
(values a1 a2)
|
||||
(values a2 a1))]
|
||||
[(nlow nhigh)
|
||||
(if (< n1 n2)
|
||||
(values n1 n2)
|
||||
(values n2 n1))]
|
||||
[(numalow numahigh)
|
||||
(values (cell-alpha->number 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)))))))))
|
||||
|
||||
Binary file not shown.
|
|
@ -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)))
|
||||
)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user