pete
/
racket-acad
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add more things

Browse Source
master
Pete Ley 10 months ago
parent 3627132664
commit c56aca0932
4 changed files with 120 additions and 61 deletions
Show Stats Download Patch File Download Diff File

90
acad.rkt
Unescape View File

@ -1,61 +1,31 @@
#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"))
(require "com.rkt")
(com-obj-prefix "acad")
(com-progid "AutoCAD.Application")
(define current-acad (make-parameter (void)))
(define current-doc (make-parameter (void)))
(define current-container (make-parameter (void)))
;; (current-acad (get-active-wco))
;; (current-doc (acad 'activedocument))
;; (current-container (acad 'modelspace))
;; (define ms ((current-doc) 'modelspace))
;; (define u ((current-doc) 'utility))
;; (define c (circle #{0.0 0.0 0.0} 1.0))
;; (define ss-coll ((current-doc) 'selectionsets))
;; (define (ss-get-or-create name)
;; (with-handlers ([exn? (lambda(_) (ss-coll 'add name))])
;; (ss-coll 'item name)))
;; (define ss (ss-get-or-create "stairs"))
(define (make-bg-acad-server) nil)
(define (call-with-readonly-dwg template filename proc)
nil)
(define (take-off-dwgs . filenames)
(current-acad (create-wco)))

57
com.rkt
Unescape View File

@ -0,0 +1,57 @@
#lang racket
(require ffi/com)
(provide (create-wrapped-instance get-active-wrapped-com-obj))
(define com-obj-prefix (make-parameter "COM"))
(define com-progid (make-parameter (void>)))
(define (create-wco)
(wrap-com-obj (com-create-instance (com-progid))))
(define (get-active-wco)
(wrap-com-obj (com-get-active-obj (com-progid))))
(define (wrapped-com-obj? x)
(with-handlers ([exn? (lambda(_) #f)])
(com-object? (x 'com-obj))))
(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 (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))))

12
racket.lsp
Unescape View File

@ -1,2 +1,12 @@
(defun send-sexp (namespace sexp)
(startapp (findfile "tcpsend.exe") (escape-quotes (strcat namespace " " (to-string sexp)))))
(startapp (findfile "tcpsend.exe")
(escape-quotes (strcat namespace " " (to-string sexp)))))
(defun data-elt->hash-repr (data-elt)
(strcat "(" (to-string (car data-elt)) " . " (to-string (cadr data-elt)) ")"))
(defun data->hash-repr (data)
(strcat "#hash(" (apply 'strcat (mapcar 'data-elt->hash-repr data)) ")"))
(defun bg-fabdata-export (filenames)
(send-sexp (cons 'take-off-dwgs (get-files-this-dir T))))

22
util.rkt
Unescape View File

@ -16,3 +16,25 @@
[keys (map string->symbol (comma-split (read-line)))]
[hash-line (lambda(line) (apply hash (zip keys line)))])
(map (compose hash-line comma-split) (port->lines))))))
;; turn a list of hashmaps into a hashmap of hashmaps keyed on inner key k
(define (listmap->mapmap listmap k)
(for/fold ([mapmap (hash)])
([h listmap])
(let* ([mapmap-list (flatten (hash->list mapmap))]
[primary-value (hash-ref h k)]
[hash-list (cons primary-value (cons h mapmap-list))])
(apply hash hash-list))))
(define (make-obj get-props set-props methods)
(lambda (msg . args)
(match args
[(list p)
#:when (member p get-props)
"get-prop"]
[(list p v)
#:when (member p set-props)
"set-prop"]
[(cons p args)
#:when (member p methods)
"method call"])))

Write Preview
Loading…
Cancel
Save