Initial commit

acad.rkt

@@ -0,0 +1,61 @@
+#lang racket
+(require ffi/com)
+
+(define acad-prog-id (make-parameter "AutoCAD.Application"))
+(define (get-active-acad) (wrap-com-obj (com-get-active-object (acad-prog-id))))
+(define (make-acad) (wrap-com-obj (com-create-instance (acad-prog-id))))
+
+(define (gather-members com-obj)
+  (apply values (map (lambda(get-func) (map string-downcase (get-func com-obj)))
+                     (list com-get-properties com-set-properties com-methods))))
+
+(define com-obj-prefix (make-parameter "acad"))
+
+(define (wrap-com-obj com-obj)
+  (read-case-sensitive #f)
+  (let-values ([(get-props set-props methods) (gather-members com-obj)])
+    (let ([print-repr (format "#<~A/~A:~A>"
+                              (com-obj-prefix)
+                              (com-object-type com-obj)
+                              (com-get-property com-obj
+                                                (cond
+                                                  [(member "name" get-props) "name"]
+                                                  [(member "objectid" get-props) "objectid"]
+                                                  [else ""])))])
+      (lambda (msg . args)
+        (let* ([msg (symbol->string msg)]
+               [result
+                (case msg
+                  [("com-obj") com-obj]
+                  [("get-props") get-props]
+                  [("set-props") set-props]
+                  [("methods") methods]
+                  [("print-repr") print-repr]
+                  [else
+                   (cond
+                     [(and (member msg set-props)
+                           (equal? (length args) 1))
+                      (com-set-property! com-obj msg (first args))]
+                     [(member msg get-props) (com-get-property com-obj msg)]
+                     [(member msg methods) (apply com-invoke com-obj msg args)])])])
+          (if (and (com-object? result)
+                   (not (eq? result com-obj)))
+              (wrap-com-obj result)
+              result))))))
+
+(define (wrapped-com-obj? x)
+  (with-handlers ([exn? (lambda(_) #f)])
+    (com-object? (x 'com-obj))))
+
+(define acad (get-active-acad))
+(define doc (acad 'activedocument))
+(define modelspace (doc 'modelspace))
+;(define util (com-get-property doc "Utility"))
+;(define c (com-invoke modelspace "AddCircle" #{0.0 0.0 0.0} 1.0))
+;(define ss-coll (com-get-property doc "SelectionSets"))
+;
+;(define (ss-get-or-create name)
+;  (with-handlers ([exn? (lambda(_) (com-invoke ss-coll "Add" name))])
+;    (com-invoke ss-coll "Item" name)))
+;
+;(define ss (ss-get-or-create "jimbo"))

evalserver.rkt

@@ -0,0 +1,31 @@
+#lang racket
+(require racket/tcp)
+
+(provide make-server)
+
+(define-syntax do-forever
+  (syntax-rules ()
+    ((do-forever thing)
+     (let loop () thing (loop)))))
+
+(define (make-server port)
+  (read-case-sensitive #f)
+  (define (accept-and-process listener)
+    (let-values ([(in _out) (tcp-accept listener)])
+      (log-and-eval (read in) (read in))
+      (tcp-abandon-port in)
+      (tcp-abandon-port _out)))
+  (define namespaces (make-hash))
+  (define (get-or-create-namespace name)
+    (hash-ref namespaces name (lambda() (let ([ns (make-base-namespace)]) (hash-set! namespaces name ns) ns))))
+  (define (log-and-eval namespace-name msg)
+    (printf "[~A]: ~A~%" namespace-name msg)
+    (with-handlers ([exn? (lambda(x) (printf "eval error: ~A~%" x))])
+      (printf "=> ~A~%" (eval msg (get-or-create-namespace namespace-name)))))
+
+  (let ([listener (tcp-listen port 1 #f "localhost")])
+    (printf "Scheme evaluation server up and running on port ~A~%" port)
+    (lambda ()
+      (do-forever (accept-and-process listener)))))
+
+((make-server 47474))

racket.lsp

@@ -0,0 +1,2 @@
+(defun send-sexp (namespace sexp)
+  (startapp (findfile "tcpsend.exe") (escape-quotes (strcat namespace " " (to-string sexp)))))

tcpsend.rkt

@@ -0,0 +1,10 @@
+#lang racket
+(require racket/tcp)
+
+(define (send port msg)
+  (let-values ([(_in out) (tcp-connect "localhost" port)])
+    (displayln msg out)
+    (tcp-abandon-port _in)
+    (tcp-abandon-port out)))
+
+(send 47474 (string-join (vector->list (current-command-line-arguments))))