From 13f44e3d78ba27b73b74d2ce84bcb3fd62e3dd11 Mon Sep 17 00:00:00 2001
From: ben <types@ccs.neu.edu>
Date: Sun, 13 Dec 2015 04:31:09 -0500
Subject: [PATCH] [math] initial checkpoint

---
 math.rkt | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 59 insertions(+)
 create mode 100644 math.rkt

diff --git a/math.rkt b/math.rkt
new file mode 100644
index 0000000..4b60ce0
--- /dev/null
+++ b/math.rkt
@@ -0,0 +1,59 @@
+#lang typed/racket/base
+
+(provide
+  +: ;-: *: /:
+  ;; Fold syntactic constants
+)
+
+(require (for-syntax
+  racket/base
+  (only-in racket/format ~a)
+  racket/syntax
+  syntax/id-table
+  syntax/parse
+  trivial/private/common
+))
+
+;; =============================================================================
+
+(define-syntax make-numeric-operator
+  (syntax-parser
+   [(_ f:id)
+    #:with f: (format-id #'f "~a:" (syntax-e #'f))
+    #'(define-syntax f:
+        (syntax-parser
+         [g:id
+          (syntax/loc #'g f)]
+         [(g e* (... ...))
+          #:with e+* (for/list ([e (in-list (syntax->list #'(e* (... ...))))])
+                       (expand-expr e))
+          #:with e++ (reduce/op f (syntax->list #'e+*) #:src #'g)
+          (syntax/loc #'g e++)]
+         [(g e* (... ...))
+          (syntax/loc #'g (f e* (... ...)))]))]))
+
+(make-numeric-operator +)
+
+;; -----------------------------------------------------------------------------
+
+(define-for-syntax (reduce/op op e* #:src stx)
+  (let loop ([prev #f]
+             [acc  '()]
+             [e*   e*])
+    (if (null? e*)
+      ;; then: combine `prev` and `acc` into a list or single number
+      (cond
+       [(null? acc)
+        (quasisyntax/loc stx #,prev)]
+       [else
+        (let ([acc+ (reverse (if prev (cons prev acc) acc))])
+          (quasisyntax/loc stx (#,op #,@acc+)))])
+      ;; else: pop the next argument from e*, fold if it's a constant
+      (syntax-parse (car e*)
+       [n:number
+        (if prev
+          ;; eval?
+          (loop (op prev (car e*)) acc (cdr e*))
+          (loop (car e*) acc (cdr e*)))]
+       [e
+        (loop #f (cons (car e*) (if prev (cons prev acc) acc)) (cdr e*))]))))