(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)))))
(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 row2 row-absolute? col1 col2 col-absolute? ))
(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)
(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?) (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 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 (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 mapped-symbols
'(+
length
=
if
quote
*
seconds
add1
map))
(define (process expr lookup lookup-row lookup-col lookup-matrix row col)
(define (cell-ref->sexp cref c-row c-col)
(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))))))
(cond [(symbol? expr)
(let ([parsed (parse-ref (string->list (symbol->string expr)))])
(cond [parsed (cell-ref->sexp parsed row col)]
[else 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 (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)))
(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))])))
(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)))))
(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]))
(provide process unprocess)
)