553 lines
22 KiB
Scheme
553 lines
22 KiB
Scheme
(module preprocessor2 mzscheme
|
|
|
|
(require (lib "string.ss")
|
|
(lib "etc.ss")
|
|
)
|
|
|
|
(define (drop l n)
|
|
(if (zero? n)
|
|
l
|
|
(drop (cdr l) (sub1 n))))
|
|
|
|
(define (caddddr lst)
|
|
(car (cdr (cdr (cdr (cdr lst))))))
|
|
|
|
(define (first lst)
|
|
(car lst))
|
|
|
|
(define (take l n)
|
|
(if (zero? n)
|
|
'()
|
|
(cons (car l)
|
|
(take (cdr l)
|
|
(sub1 n)))))
|
|
|
|
;; ('a -> bool) * 'a list -> (#f or num)
|
|
(define position-of-first-satisfied-in-list
|
|
(lambda (pred l)
|
|
(let loop ((i 0) (l l))
|
|
(if (null? l) #f
|
|
(if (pred (car l)) i
|
|
(loop (+ i 1) (cdr l)))))))
|
|
|
|
(define position-of-object-in-list
|
|
(lambda (o l)
|
|
(position-of-first-satisfied-in-list (lambda (x)
|
|
(eqv? o x))
|
|
l)))
|
|
|
|
(define capitals
|
|
'(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z))
|
|
|
|
(define lower-case
|
|
(let loop ([i 97])
|
|
(if (<= i 122)
|
|
(cons (integer->char i)
|
|
(loop (add1 i)))
|
|
'())))
|
|
|
|
(define digits
|
|
'(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0))
|
|
|
|
(define (contains? i lst)
|
|
(and (not (null? lst))
|
|
(or (equal? i (car lst))
|
|
(contains? i (cdr lst)))))
|
|
|
|
(define (capital? char)
|
|
(contains? char capitals))
|
|
(define (lower-case? char)
|
|
(contains? char lower-case))
|
|
(define (digit? char)
|
|
(contains? char digits))
|
|
(define (letter? char)
|
|
(or (capital? char)
|
|
(lower-case? char)))
|
|
|
|
(define-struct cell-reference (row1 ; num
|
|
row2 ; num
|
|
row-absolute? ; bool
|
|
col1 ; num
|
|
col2 ; num
|
|
col-absolute? ; bool
|
|
))
|
|
|
|
(define (capital->col-num char)
|
|
(- (char->integer char)
|
|
65))
|
|
|
|
(define (lower-case->col-num char)
|
|
(- (char->integer char)
|
|
97))
|
|
|
|
#;(define (letter->col-num char)
|
|
(if (capital? char)
|
|
(capital->row-num char)
|
|
(lower-case->row-num char)))
|
|
|
|
(define (digit->row-num char)
|
|
(- (char->integer char)
|
|
48))
|
|
|
|
#;(define (letter-list->col-num llst)
|
|
(let loop ([num -1]
|
|
[lst llst])
|
|
(cond [(null? lst)
|
|
num]
|
|
[(capital? (car lst))
|
|
(loop (+ (* (add1 num) 26)
|
|
(capital->row-num (car lst)))
|
|
(cdr lst))]
|
|
[(lower-case? (car lst))
|
|
(loop (+ (* (add1 num) 26)
|
|
(lower-case->col-num (car lst)))
|
|
(cdr lst))])))
|
|
|
|
(define (digit-list->row-num nlist)
|
|
(let loop ([num 0]
|
|
[lst nlist])
|
|
(cond [(null? lst)
|
|
num]
|
|
[(digit? (car lst))
|
|
(loop (+ (* num 10)
|
|
(digit->row-num (car lst)))
|
|
(cdr lst))])))
|
|
|
|
(define NOT-A-CELL-REFERENCE #f)
|
|
|
|
;; char list -> cell-reference
|
|
(define (parse-ref char-list)
|
|
(let loop ([lst char-list]
|
|
[reading-col-section #t]
|
|
[row1 #f]
|
|
[row2 #f]
|
|
[row-absolute? #f]
|
|
[col1 #f]
|
|
[col2 #f]
|
|
[col-absolute? #f])
|
|
(cond [(null? lst)
|
|
(if (and row1 row2 col1 col2 (not reading-col-section))
|
|
(make-cell-reference row1 row2 row-absolute? col1 col2 col-absolute?)
|
|
NOT-A-CELL-REFERENCE)]
|
|
[reading-col-section
|
|
(cond [(equal? (car lst)
|
|
#\$)
|
|
(if (or col1 col-absolute?) ;; then already hit first $, so this must refer to numbers
|
|
(loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)
|
|
(loop (cdr lst)
|
|
#t
|
|
row1 row2 row-absolute?
|
|
col1 col2
|
|
#t))]
|
|
[(letter? (car lst))
|
|
(let ([next (position-of-first-satisfied-in-list
|
|
(lambda (o)
|
|
(or (equal? o #\$)
|
|
(equal? o #\:)
|
|
(digit? o)))
|
|
lst)])
|
|
(if col1
|
|
(if next
|
|
(if (equal? 'invalid
|
|
(letter-list->col-num (take lst
|
|
next)))
|
|
NOT-A-CELL-REFERENCE
|
|
(loop (drop lst next)
|
|
#t ; should get switched in next iteration
|
|
row1 row2 row-absolute?
|
|
col1
|
|
(letter-list->col-num (take lst
|
|
next))
|
|
col-absolute?))
|
|
NOT-A-CELL-REFERENCE
|
|
)
|
|
(if next
|
|
(if (equal? 'invalid
|
|
(letter-list->col-num (take lst
|
|
next)))
|
|
NOT-A-CELL-REFERENCE
|
|
(loop (drop lst
|
|
next)
|
|
#t
|
|
row1 row2 row-absolute?
|
|
(letter-list->col-num (take lst
|
|
next))
|
|
(letter-list->col-num (take lst next))
|
|
col-absolute?))
|
|
NOT-A-CELL-REFERENCE
|
|
)))]
|
|
[(equal? (car lst) #\:)
|
|
(if col1
|
|
(loop (cdr lst) #t row1 row2 row-absolute? col1 col2 col-absolute?)
|
|
NOT-A-CELL-REFERENCE)]
|
|
[(digit? (car lst))
|
|
(loop lst #f row1 row2 row-absolute? col1 col2 col-absolute?)]
|
|
[else NOT-A-CELL-REFERENCE])]
|
|
[else ; reading NUMBER/ROW section section
|
|
(cond [(equal? (car lst)
|
|
#\$)
|
|
(loop (cdr lst) #f row1 row2 #t col1 col2 col-absolute? ;!!
|
|
)]
|
|
[(digit? (car lst))
|
|
(let ([next (position-of-first-satisfied-in-list
|
|
(lambda (o)
|
|
(not (digit? o)))
|
|
lst)])
|
|
(if row1
|
|
(if next
|
|
NOT-A-CELL-REFERENCE
|
|
(loop '()
|
|
#f
|
|
row1
|
|
(digit-list->row-num lst)
|
|
row-absolute?
|
|
col1 col2 col-absolute?))
|
|
(if next
|
|
(loop (drop lst next)
|
|
#f
|
|
(digit-list->row-num (take lst next))
|
|
(digit-list->row-num (take lst next))
|
|
row-absolute?
|
|
col1 col2 col-absolute?)
|
|
(loop '()
|
|
#f
|
|
(digit-list->row-num lst)
|
|
(digit-list->row-num lst)
|
|
row-absolute?
|
|
col1 col2 col-absolute?))))]
|
|
[(equal? (car lst)
|
|
#\:)
|
|
(loop (cdr lst) #t
|
|
row1 row2 row-absolute?
|
|
col1 col2 col-absolute?)]
|
|
[else
|
|
NOT-A-CELL-REFERENCE])])))
|
|
|
|
;
|
|
;(define pt1 '(#\a #\b #\1 #\2))
|
|
;(define pt1- (make-cell-reference 12 12 #f 27 27 #f))
|
|
;(define pt2 '(#\$ #\a #\b #\4))
|
|
;(define pt2- (make-cell-reference 4 4 #f 27 27 #t))
|
|
;(define pt3 '(#\a #\$ #\4))
|
|
;(define pt3- (make-cell-reference 4 4 #t 0 0 #f))
|
|
;(define pt4 '(#\a #\: #\e #\5))
|
|
;(define pt4- (make-cell-reference 5 5 #f 0 4 #f))
|
|
;(define pt5 '(#\z #\1 #\: #\8))
|
|
;(define pt5- (make-cell-reference 1 8 #f 25 25 #f))
|
|
;(define pt6 '(#\$ #\a #\: #\d #\1))
|
|
;(define pt6- (make-cell-reference 1 1 #f 0 3 #t))
|
|
;(define pt7 '(#\$ #\a #\$ #\0))
|
|
;(define pt7- (make-cell-reference 0 0 #t 0 0 #t))
|
|
;
|
|
;(define (equal-cell-refs? c1 c2)
|
|
; (and (equal? (cell-reference-row1 c1)
|
|
; (cell-reference-row1 c2))
|
|
; (equal? (cell-reference-row2 c1)
|
|
; (cell-reference-row2 c2))
|
|
; (equal? (cell-reference-row-absolute? c1)
|
|
; (cell-reference-row-absolute? c2))
|
|
; (equal? (cell-reference-col1 c1)
|
|
; (cell-reference-col1 c2))
|
|
; (equal? (cell-reference-col2 c1)
|
|
; (cell-reference-col2 c2))
|
|
; (equal? (cell-reference-col-absolute? c1)
|
|
; (cell-reference-col-absolute? c2))))
|
|
;
|
|
;(equal-cell-refs? (parse-ref pt1) pt1-)
|
|
;(equal-cell-refs? (parse-ref pt2) pt2-)
|
|
;(equal-cell-refs? (parse-ref pt3) pt3-)
|
|
;(equal-cell-refs? (parse-ref pt4) pt4-)
|
|
;(equal-cell-refs? (parse-ref pt5) pt5-)
|
|
;(equal-cell-refs? (parse-ref pt6) pt6-)
|
|
;(equal-cell-refs? (parse-ref pt7) pt7-)
|
|
|
|
|
|
(define mapped-symbols
|
|
'(+
|
|
length
|
|
=
|
|
if
|
|
quote
|
|
*
|
|
seconds
|
|
add1
|
|
map))
|
|
|
|
|
|
;process: sexp symbol symbol symbol symbol num num -> sexp
|
|
;INPUT: An expression EXPR, the name of lookup procedures LOOKUP, LOOKUP-ROW, LOOKUP-COL, LOOKUP-MATRIX and the current row and column
|
|
; for the cell being processed, ROW and COL.
|
|
;OUTPUT: blah blah blah
|
|
(define (process expr lookup lookup-row lookup-col lookup-matrix row col)
|
|
(define (cell-ref->sexp cref c-row c-col)
|
|
;; cell-reference * num * num -> sexp
|
|
(let ([ref-row1 (cell-reference-row1 cref)]
|
|
[ref-col1 (cell-reference-col1 cref)]
|
|
[ref-row2 (cell-reference-row2 cref)]
|
|
[ref-col2 (cell-reference-col2 cref)]
|
|
[row-ref-expr (lambda (n)
|
|
(if (cell-reference-row-absolute? cref)
|
|
n
|
|
(list '+ 'row (- n c-row))))]
|
|
[col-ref-expr (lambda (n)
|
|
(if (cell-reference-col-absolute? cref)
|
|
n
|
|
(list '+ 'col (- n c-col))))])
|
|
(if (not (= ref-row1 ref-row2))
|
|
(if (not (= ref-col1 ref-col2))
|
|
(list lookup-matrix
|
|
(row-ref-expr ref-row1)
|
|
(row-ref-expr ref-row2)
|
|
(col-ref-expr ref-col1)
|
|
(col-ref-expr ref-col2))
|
|
(list lookup-col
|
|
(row-ref-expr ref-row1)
|
|
(row-ref-expr ref-row2)
|
|
(col-ref-expr ref-col1)))
|
|
(if (not (= ref-col1 ref-col2))
|
|
(list lookup-row
|
|
(row-ref-expr ref-row1)
|
|
(col-ref-expr ref-col1)
|
|
(col-ref-expr ref-col2))
|
|
(list lookup
|
|
(row-ref-expr ref-row1)
|
|
(col-ref-expr ref-col1))))))
|
|
;; end of cell reference handling
|
|
(cond [(symbol? expr)
|
|
(let ([parsed (parse-ref (string->list (symbol->string expr)))])
|
|
(cond [parsed (cell-ref->sexp parsed row col)]
|
|
[else ;; currently allowing all symbols.
|
|
expr]))]
|
|
[(list? expr)
|
|
(if (and (not (null? expr))
|
|
(equal? 'quote (car expr)))
|
|
expr
|
|
(map (lambda (sexp)
|
|
(process sexp lookup lookup-row lookup-col lookup-matrix row col))
|
|
expr))]
|
|
[else expr]))
|
|
|
|
|
|
|
|
|
|
;(define t1 "a:zz$1")
|
|
;(define t2 "length")
|
|
;(define t3 "(+ 3 4)")
|
|
;(define t4 "(+ 2 a3)")
|
|
;(define t5 "(if (= 3 (length A1)) (a2 $A3) 'dont-see)")
|
|
;(define t6 "(ZD941 A:d3:40)")
|
|
;
|
|
;(define p (lambda (e)
|
|
; (process (read (open-input-string e)) 'lookup 'lookup-row 'lookup-col 'lookup-matrix 1 1)))
|
|
;t1 (p t1)
|
|
;t2 (p t2)
|
|
;t3 (p t3)
|
|
;t4 (p t4)
|
|
;t5 (p t5)
|
|
;t6 (p t6)
|
|
|
|
|
|
;; ISSUES:
|
|
;; - When going from cell-references to symbols, be careful about LETTERS referring to COLUMNS
|
|
;; and NUMBERS referring to ROWS. Some procedures are still BROKEN because of this.
|
|
;;
|
|
;; - Now a lookup expression has more information about what sort of region it is looking up
|
|
;; (singleton, row, column, matrix). Use this when converting from lookup expressions to
|
|
;; cell references.
|
|
;;
|
|
;; - Now that lookup expressions contain all the information contained within cell references,
|
|
;; the intermediate step between expressions and cell references is UNNECESSARY. I should
|
|
;; have procedure's LOOKUP-EXPR->SYMBOL that take care of everything for the UNPROCESSOR.
|
|
;;
|
|
(define (letter-list->col-num llst)
|
|
(let ([col-num (let loop ([num -1]
|
|
[lst llst])
|
|
(cond [(null? lst)
|
|
num]
|
|
[(capital? (car lst))
|
|
(loop (+ (* (add1 num) 26)
|
|
(capital->col-num (car lst)))
|
|
(cdr lst))]
|
|
[(lower-case? (car lst))
|
|
(loop (+ (* (add1 num) 26)
|
|
(lower-case->col-num (car lst)))
|
|
(cdr lst))]))])
|
|
(if (>= col-num 702)
|
|
'invalid
|
|
col-num)))
|
|
|
|
; num -> char list
|
|
(define (col-num->letter-list n)
|
|
(let loop ([num n]
|
|
[lst '()])
|
|
(cond [(= -1 num)
|
|
lst]
|
|
[else (loop (sub1 (quotient num 26))
|
|
(cons (integer->char (+ 97 (remainder num 26)))
|
|
lst))])))
|
|
|
|
; num -> char list
|
|
(define (row-num->digit-list n)
|
|
(define help
|
|
(lambda (n)
|
|
(let ([r (remainder n 10)]
|
|
[q (quotient n 10)])
|
|
(if (zero? q)
|
|
(list (integer->char (+ 48 n)))
|
|
(cons (integer->char (+ 48 r))
|
|
(help q))))))
|
|
(reverse (help n)))
|
|
|
|
|
|
|
|
(define (lookup-expr->symbol expr local-row local-col)
|
|
(let* ([row-expr (cadr expr)]
|
|
[col-expr (caddr expr)]
|
|
[row-chars (cond [(number? row-expr)
|
|
(cons #\$
|
|
(row-num->digit-list row-expr))]
|
|
[(list? row-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row-expr)))])]
|
|
[col-chars (cond [(number? col-expr)
|
|
(cons #\$
|
|
(col-num->letter-list col-expr))]
|
|
[(list? col-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col-expr)))])])
|
|
|
|
(string->symbol (list->string (append col-chars
|
|
row-chars)))))
|
|
|
|
(define (lookup-row-expr->symbol expr local-row local-col)
|
|
(let* ([row-expr (cadr expr)]
|
|
[col1-expr (caddr expr)]
|
|
[col2-expr (cadddr expr)]
|
|
[row-chars (cond [(number? row-expr)
|
|
(cons #\$
|
|
(row-num->digit-list row-expr))]
|
|
[(list? row-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row-expr)))])]
|
|
[col1-chars (cond [(number? col1-expr)
|
|
(cons #\$
|
|
(col-num->letter-list col1-expr))]
|
|
[(list? col1-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col1-expr)))])]
|
|
[col2-chars (cons #\:
|
|
(cond [(number? col2-expr)
|
|
(col-num->letter-list col2-expr)]
|
|
[(list? col2-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col2-expr)))]))])
|
|
(string->symbol (list->string (append col1-chars
|
|
col2-chars
|
|
row-chars)))))
|
|
|
|
(define (lookup-col-expr->symbol expr local-row local-col)
|
|
(let* ([row1-expr (cadr expr)]
|
|
[row2-expr (caddr expr)]
|
|
[col-expr (cadddr expr)]
|
|
[row1-chars (cond [(number? row1-expr)
|
|
(cons #\$
|
|
(row-num->digit-list row1-expr))]
|
|
[(list? row1-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row1-expr)))])]
|
|
[row2-chars (cons #\:
|
|
(cond [(number? row2-expr)
|
|
(row-num->digit-list row2-expr)]
|
|
[(list? row2-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row2-expr)))]))]
|
|
[col-chars (cond [(number? col-expr)
|
|
(cons #\$
|
|
(col-num->letter-list col-expr))]
|
|
[(list? col-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col-expr)))])])
|
|
|
|
(string->symbol (list->string (append col-chars
|
|
row1-chars
|
|
row2-chars)))))
|
|
|
|
(define (lookup-matrix-expr->symbol expr local-row local-col)
|
|
(let* ([row1-expr (cadr expr)]
|
|
[row2-expr (caddr expr)]
|
|
[col1-expr (cadddr expr)]
|
|
[col2-expr (caddddr expr)]
|
|
[row1-chars (cond [(number? row1-expr)
|
|
(cons #\$
|
|
(row-num->digit-list row1-expr))]
|
|
[(list? row1-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row1-expr)))])]
|
|
[row2-chars (cons #\:
|
|
(cond [(number? row2-expr)
|
|
(row-num->digit-list row2-expr)]
|
|
[(list? row2-expr)
|
|
(row-num->digit-list (+ local-row
|
|
(caddr row2-expr)))]))]
|
|
[col1-chars (cond [(number? col1-expr)
|
|
(cons #\$
|
|
(col-num->letter-list col1-expr))]
|
|
[(list? col1-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col1-expr)))])]
|
|
[col2-chars (cons #\:
|
|
(cond [(number? col2-expr)
|
|
(col-num->letter-list col2-expr)]
|
|
[(list? col2-expr)
|
|
(col-num->letter-list (+ local-col
|
|
(caddr col2-expr)))]))])
|
|
(string->symbol (list->string (append col1-chars
|
|
col2-chars
|
|
row1-chars
|
|
row2-chars)))))
|
|
|
|
|
|
|
|
; sexp * symbol * symbol *symbol *symbol num * num -> sexp
|
|
(define (unprocess expr lookup lookup-row lookup-col lookup-matrix local-row local-col)
|
|
(cond [(list? expr)
|
|
(cond [(null? expr)
|
|
'()]
|
|
[(equal? (first expr) lookup)
|
|
(lookup-expr->symbol expr local-row local-col)]
|
|
[(equal? (first expr) lookup-row)
|
|
(lookup-row-expr->symbol expr local-row local-col)]
|
|
[(equal? (first expr) lookup-col)
|
|
(lookup-col-expr->symbol expr local-row local-col)]
|
|
[(equal? (first expr) lookup-matrix)
|
|
(lookup-matrix-expr->symbol expr local-row local-col)]
|
|
[(equal? (first expr) 'quote)
|
|
expr]
|
|
[else
|
|
(map (lambda (e)
|
|
(unprocess e lookup lookup-row lookup-col
|
|
lookup-matrix local-row local-col))
|
|
expr)])]
|
|
[else
|
|
expr]))
|
|
;
|
|
;(define te1
|
|
; '((lookup 3 4)
|
|
; '(lookup 3 4)
|
|
; (1 2 (lookup 0 0))
|
|
; (lookup-matrix (+ row 0) (+ row 5) (+ col 2) (+ col 5))
|
|
; (lookup-row 5 (+ col 1) (+ col 20))
|
|
; (lookup-col 3 39 (+ col 0))))
|
|
;
|
|
;(unprocess te1
|
|
; 'lookup
|
|
; 'lookup-row
|
|
; 'lookup-col
|
|
; 'lookup-matrix
|
|
; 1
|
|
; 1)
|
|
|
|
|
|
(provide process unprocess)
|
|
|
|
) |