improve dot generation

dot.rkt

@@ -0,0 +1,74 @@
+#lang racket/base
+
+(provide
+ dot-digraph
+ dot-vertex
+ dot-edge)
+
+(module+ test
+  (require rackunit
+           racket/port))
+
+;; -----------------------------------------------------------------------------
+
+(define (dot-digraph f)
+  (write-string "digraph {\n")
+  (f)
+  (write-string "}\n"))
+
+(define (dot-vertex id #:label [label #f] #:shape [shape #f])
+  (let* ([params '()]
+         [params (if shape (cons (cons 'shape shape) params) params)]
+         [params (if label (cons (cons 'label label) params) params)])
+    (write id)
+    (for/fold ([beg "["] [end ""] #:result (write-string end))
+              ([param (in-list params)])
+      (write-string beg)
+      (printf "~a=~s" (car param) (cdr param))
+      (values "," "]"))
+    (write-string ";\n")))
+
+(define (dot-edge a b #:flip? [flip? #f])
+  (printf "~a -> ~a;\n"
+          (if flip? b a)
+          (if flip? a b)))
+
+(module+ test
+
+  (check-equal?
+   (with-output-to-string
+     (λ ()
+       (dot-digraph
+        (λ ()
+          (dot-vertex 'a)
+          (dot-vertex 'b #:label "B")
+          (dot-vertex 'c #:shape 'box)
+          (dot-vertex 'd #:label "D" #:shape 'box)))))
+   (string-append
+    "digraph {\n"
+    "a;\n"
+    "b[label=\"B\"];\n"
+    "c[shape=box];\n"
+    "d[label=\"D\",shape=box];\n"
+    "}\n"))
+
+  (check-equal?
+   (with-output-to-string
+     (λ ()
+       (dot-digraph
+        (λ ()
+          (dot-vertex 'a)
+          (dot-vertex 'b)
+          (dot-vertex 'c)
+          (dot-edge 'a 'b)
+          (dot-edge 'b 'c)
+          (dot-edge 'a 'c #:flip? #t)))))
+   (string-append
+    "digraph {\n"
+    "a;\nb;\nc;\n"
+    "a -> b;\n"
+    "b -> c;\n"
+    "c -> a;\n"
+    "}\n"))
+
+  )

main.rkt

@@ -11,9 +11,11 @@
  "./scrape.rkt"
  "./database.rkt"
  "./sle.rkt"
+ "./dot.rkt"
 
  (rename-in "./logging.rkt"
             [log-calc-info INFO]
+            [log-calc-error ERROR]
             [log-calc-debug DEBUG]))
 
 ;; -----------------------------------------------------------------------------
@@ -30,7 +32,7 @@
 
 (define (recipe-filter* r)
   (and (recipe-info-building r)
-       (not (recipe-info-alternate? r))
+       ;(not (recipe-info-alternate? r))
        (for/and ([i (in-hash-keys (recipe-info-ratios r))])
          (query-item i))))
 
@@ -44,19 +46,17 @@
   ;(unless allow? (DEBUG "recipe filtered out: ~s" (recipe-info-name i)))
   allow?)
 
-(define input-file-path (make-parameter "problem.rktd"))
-(define print-dot? (make-parameter #f))
-
-(define (main)
-  (define problem (with-input-from-file (input-file-path) simple-read-and-eval))
-  (define inputs (hash-ref problem 'inputs '()))
-  (define outputs (hash-ref problem 'outputs hasheq))
-  (define recipes (hash-ref problem 'recipes '()))
+(define (main #:input-file in-file
+              #:print-dot? dot?)
+  (define problem (with-input-from-file in-file simple-read-and-eval))
+  (define input-names (hash-ref problem 'inputs '()))
+  (define output-names/qty (hash-ref problem 'outputs hasheq))
+  (define recipe-names (hash-ref problem 'recipes '()))
   (define period (hash-ref problem 'period 60))
 
-  (DEBUG "inputs: ~s" inputs)
-  (DEBUG "outputs: ~s" outputs)
-  (DEBUG "recipes: ~s" recipes)
+  (DEBUG "inputs: ~s" input-names)
+  (DEBUG "outputs: ~s" output-names/qty)
+  (DEBUG "recipes: ~s" recipe-names)
   (DEBUG "period: ~as" period)
 
   (current-item-database
@@ -76,33 +76,41 @@
   (define item=>lhs (make-hasheq))
   (define item=>rhs (make-hasheq))
 
-  (for ([r-name (in-list recipes)])
-    (define r-info (query-recipe r-name))
+  (for ([name (in-list input-names)])
+    (define info
+      (or (query-item name)
+          (raise-user-error (format "undefined input item: ~s" name))))
+    (define cn (item-info-classname info))
+    (DEBUG "init input: ~s (~a)" (item-info-name info) cn)
+    (hash-set! item=>lhs cn (lexpr 0))
+    (hash-set! item=>rhs cn (symbol->lexpr cn)))
+
+  (for ([(name qty) (in-hash output-names/qty)])
+    (define info
+      (or (query-item name)
+          (error (format "undefined output item: ~s" name))))
+    (define cn (item-info-classname info))
+    (DEBUG "init output: ~s (~a)" (item-info-name info) qty)
+    (hash-set! item=>lhs cn (lexpr 0))
+    (hash-set! item=>rhs cn (number->lexpr (/ qty period))))
+
+  (for ([r-name (in-list recipe-names)])
+    (define r-info
+      (or (query-recipe r-name)
+          (raise-user-error (format "undefined recipe: ~s" r-name))))
     (define r-cn (recipe-info-classname r-info))
     (DEBUG "begin recipe: ~s (~a)" (recipe-info-name r-info) r-cn)
     (for ([(i-cn ratio) (in-hash (recipe-info-ratios r-info))])
       (define (add e) (lexpr+ e (lexpr* ratio (symbol->lexpr r-cn))))
       (hash-update! item=>lhs i-cn add (lexpr 0))))
 
-  (for ([name (in-list inputs)])
-    (define info (query-item name))
-    (define cn (item-info-classname info))
-    (DEBUG "init input: ~s (~a)" (item-info-name info) cn)
-    (hash-set! item=>rhs cn (symbol->lexpr cn)))
-
-  (for ([(name qty) (in-hash outputs)])
-    (define info (query-item name))
-    (define cn (item-info-classname info))
-    (DEBUG "init output: ~s (~a)" (item-info-name info) qty)
-    (hash-set! item=>rhs cn (number->lexpr (/ qty period))))
-
   (define sle (make-sle))
   (for ([cn (in-hash-keys item=>lhs)])
     (define lhs (hash-ref item=>lhs cn))
     (define rhs (hash-ref item=>rhs cn (lexpr 0)))
     (sle-equal! sle lhs rhs))
 
-  (define (format-amt x) (~r x #:sign '++ #:precision 2))
+  (define (format-amt x) (~r x #:sign '++ #:precision 1))
   (define (format-qty n) (string-append (~r n #:precision 2) "x"))
 
   (define (item-amt-string i)
@@ -117,75 +125,69 @@
     (parameterize ([current-lexpr-number->string format-qty])
       (lexpr->string value)))
 
+  (define items
+    (sort (map query-item (hash-keys item=>lhs))
+          string<? #:key item-info-name))
+  (define recipes
+    (sort (map query-recipe recipe-names)
+          string<? #:key recipe-info-name))
+
   (INFO "Net items:")
-  (let ([items (sort (map query-item (hash-keys item=>lhs))
-                     string<? #:key item-info-name)])
-    (for ([info (in-list items)])
-      (INFO "~a ~s"
-            (~a (item-amt-string info) #:min-width 5 #:align 'right)
-            (item-info-name info))))
+  (for ([i (in-list items)])
+    (INFO "~a ~s"
+          (~a (item-amt-string i) #:min-width 5 #:align 'right)
+          (item-info-name i)))
 
   (INFO "Recipes:")
-  (for ([name (in-list recipes)])
-    (define info (query-recipe name))
+  (for ([r (in-list recipes)])
     (INFO "~a ~s"
-          (~a (recipe-qty-string info) #:min-width 5 #:align 'right)
-          (recipe-info-name info)))
+          (~a (recipe-qty-string r) #:min-width 5 #:align 'right)
+          (recipe-info-name r)))
+
+  (when dot?
+    (define item=>recipes (make-hasheq))
+    (for* ([r (in-list recipes)]
+           [i-cn (in-hash-keys (recipe-info-ratios r))])
+      (define (add rs) (cons r rs))
+      (hash-update! item=>recipes (query-item i-cn) add '()))
+
+    (define item=>kind (make-hasheq))
+    (for ([n (in-list input-names)]) (hash-set! item=>kind (query-item n) 'input))
+    (for ([n (in-hash-keys output-names/qty)]) (hash-set! item=>kind (query-item n) 'output))
 
-  (when (print-dot?)
     (DEBUG "generating DOT graph")
-    (let ([recipes (map query-recipe recipes)]
-          [inputs (map query-item inputs)]
-          [outputs (map query-item (hash-keys outputs))])
-      (define item=>recipes (make-hasheq))
+    (dot-digraph
+     (λ ()
+       (for ([r (in-list recipes)])
+         (dot-vertex (recipe-info-classname r)
+                     #:label (format "~a\n~a" (recipe-info-name r)
+                                     (recipe-qty-string r))
+                     #:shape 'box))
 
-      (for* ([r (in-list recipes)]
-             [i-cn (in-hash-keys (recipe-info-ratios r))])
-        (define (add rs) (cons r rs))
-        (hash-update! item=>recipes i-cn add '()))
+       (for ([i (in-list items)] #:when (hash-has-key? item=>kind i))
+         (dot-vertex (item-info-classname i)
+                     #:label (format "~a\n~a"
+                                     (item-info-name i)
+                                     (item-amt-string i))))
 
-      (printf "digraph {\n")
-
-      (for ([i (in-list (append inputs outputs))])
-        (define i-cn (item-info-classname i))
-        (define label (format "~a\n~a" (item-info-name i) (item-amt-string i)))
-        (printf "~a [" i-cn)
-        (printf "label=~s" label)
-        (printf "];\n"))
-
-      (for ([r (in-list recipes)])
-        (define r-cn (recipe-info-classname r))
-        (define label (format "~a\n~a" (recipe-info-name r) (recipe-qty-string r)))
-        (printf "~a [" r-cn)
-        (printf "shape=box,label=~s" label)
-        (printf "];\n"))
-
-      (for* ([(i-cn rs) (in-hash item=>recipes)]
-             [r12 (in-combinations rs 2)]
-             #:do [(define r1 (car r12))
-                   (define r2 (cadr r12))
-                   (define v1 (hash-ref (recipe-info-ratios r1) i-cn))
-                   (define v2 (hash-ref (recipe-info-ratios r2) i-cn))]
-             ; signs differ
-             #:when (negative? (* v1 v2)))
-        (define cn1 (recipe-info-classname r1))
-        (define cn2 (recipe-info-classname r2))
-        (if (negative? v1)
-            ; r1 is sink, r2 is source
-            (printf "~a -> ~a;\n" cn2 cn1)
-            ; r1 is source, r2 is sink
-            (printf "~a -> ~a;\n" cn1 cn2)))
-
-      (for* ([i (in-list (append inputs outputs))]
-             #:do [(define i-cn (item-info-classname i))]
-             [r (in-list (hash-ref item=>recipes i-cn '()))])
-        (define r-cn (recipe-info-classname r))
-        (define v (hash-ref (recipe-info-ratios r) i-cn))
-        (if (negative? v)
-            (printf "~a -> ~a;\n" i-cn r-cn)
-            (printf "~a -> ~a;\n" r-cn i-cn)))
-
-      (printf "}\n")))
+       (for ([i (in-list items)])
+         (define i-cn (item-info-classname i))
+         (define rs (hash-ref item=>recipes i '()))
+         (match (hash-ref item=>kind i 'recipe)
+           [(or 'input 'output)
+            (for ([r (in-list rs)])
+              (define r-cn (recipe-info-classname r))
+              (define v (hash-ref (recipe-info-ratios r) i-cn))
+              (dot-edge r-cn i-cn #:flip? (negative? v)))]
+           ['recipe
+            (for ([r12 (in-combinations rs 2)])
+              (match-define (list r1 r2) r12)
+              (define r1-cn (recipe-info-classname r1))
+              (define r2-cn (recipe-info-classname r2))
+              (define v1 (hash-ref (recipe-info-ratios r1) i-cn))
+              (define v2 (hash-ref (recipe-info-ratios r2) i-cn))
+              (unless (eq? (negative? v1) (negative? v2))
+                (dot-edge r1-cn r2-cn #:flip? (negative? v1))))])))))
 
   (void))
 
@@ -206,8 +208,6 @@
 (module+ main
   (require racket/cmdline)
 
-  (define verbose (make-parameter 0))
-
   (define (time-string)
     (parameterize ([date-display-format 'iso-8601])
       (date->string (current-date) #t)))
@@ -224,22 +224,23 @@
                [_ ""])
              msg))
 
+  (define verbose 0)
+  (define dot? #f)
+
   (command-line
    #:multi
-   [("-v" "--verbose")
-    "Verbose log messages"
-    (verbose (add1 (verbose)))]
+   [("-v" "--verbose") "Verbose log messages" (set! verbose (add1 verbose))]
    #:once-each
-   [("--dot")
-    "Print DOT graph"
-    (print-dot? #t)]
-   #:args ([infile (input-file-path)]) (input-file-path infile))
-
-  (with-intercepted-logging
-    print-log
-    main
-    (cond
-      [(= (verbose) 2) 'debug]
-      [(= (verbose) 1) 'info]
-      [else 'warning])
-    #:logger calc-logger))
+   [("--dot") "Print DOT graph" (set! dot? #t)]
+   #:args (input-file)
+   (with-intercepted-logging
+     print-log
+     (λ ()
+       (with-handlers ([exn:fail:user? (λ (e) (ERROR "~a" (exn-message e)))])
+         (main #:input-file input-file
+               #:print-dot? dot?)))
+     (cond
+       [(> verbose 1) 'debug]
+       [(> verbose 0) 'info]
+       [else 'warning])
+     #:logger calc-logger)))

problem.rktd

@@ -1,19 +1,33 @@
-(define recipes
-  (list "supercomputer"
-        "computer"
-        "circuit board"
-        "ai limiter"
-        "high-speed connector"))
-
 (define inputs
-  (list "plastic"
-        "cable"
-        "quickwire"
-        "copper sheet"))
+  (list
+   "copper ore"
+   "caterium ore"
+   "plastic"
+   ))
 
 (define outputs
-  (hash "supercomputer" 1
-        ;"computer" 4
-        ;"circuit board" 10
-        ;"high-speed connector" 1
-        ))
+  (hash
+   "supercomputer" 1
+   "computer" 4
+   "circuit board" 10
+   ;"high-speed connector" 1
+   ))
+
+(define recipes
+  (list
+   "caterium ingot"
+   "copper ingot"
+
+   ;"caterium wire"
+   "wire"
+   "quickwire"
+   "cable"
+   "copper sheet"
+
+   "supercomputer"
+   "high-speed connector"
+
+   "computer"
+   "circuit board"
+   "ai limiter"
+   ))