[racket] Detecting cycle in directed graph

On Feb 14, 2014, at 7:42 AM, Erich Rast wrote:

> I have a directed graph given as list of pairs ((from-node .
> to-node) ...) and need to detect whether adding a pair would create a
> cycle.
> 
> Is there an easy way to do this already, e.g. some Planet package or
> snippet someone would like to share? 
> 
> I don't want to reinvent the wheel and this is not a homework question.




I thought it looked like the first homework from my junior-level sw dev course last year but when I checked the interface, my requirement was to conform to the triangle inequality. Sorry, no luck 


#lang racket

(require "../Lib/contract.rkt")

;; ---------------------------------------------------------------------------------------------------
;; for contracts see below
(provide
 node?
 edge?
 edge
 edge-from
 edge-to  
 edge-cost
 reverse-edge
 graph/c)

(interface graph& 
  (node?     (-> any/c boolean?))
  (edge?     contract?)
  (edge      (-> node? real? node? edge?)) ;; MF: forgot to export it
  (edge-from (-> edge? node?))
  (edge-to   (-> edge? node?))
  (edge-cost (-> edge? number?))
  graph/c
  (graph%    graph/c))

;; an interface needs a common terminology with an interpretation (see Fundamentals I, ontology)

;; nodes 
(define node? symbol?)

;; edges 
(define edge?
  (list/c node? real? node?))
(define/contract (edge from cost to)
  (-> node? real? node? edge?)
  (list from cost to))
(define edge-from first)
(define edge-cost second)
(define edge-to third)
(define reverse-edge reverse)

(define (cost/c low high)
  ;; MF: while I can't enforce invariants on fields 
  (λ (x) (<= low x high))
  #;
  (and/c  (>=/c low) (<=/c high)))

;; graphs 
(define graph/c
  (class/c
   ;; specify the interval of costs [low-cost,high-cost]
   (init-field (low-cost (and/c real? (>=/c 0)))) ;; MF: made cost non-negative 
   ;; MF: Racket's contract system is deficient here:
   (init-field (high-cost (and/c real? (>=/c 0) #;(>/c low-cost))))
   ;; and I want this to be interpreted as an invariant
   (nodes
    ;; the list of nodes of this graph 
    (->m (set/c node? #:cmp 'eq)))
   (edges
    ;; the list of edges of this graph 
    (->m (set/c edge? #:cmp 'equal)))
   (add-edge
    ;; adding an edge (from,to) with cost w to this graph 
    (->dm ((from node?) 
           (w (cost/c (get-field low-cost this) (get-field high-cost this)))
           (to node?))
          #:pre (triangle-condition-preserved (send this edges) from w to)
          any))
   ;; MF: I had not anticipated that I would want an 'inherited' call
   (inherit (add-edge
             ;; adding an edge (from,to) with cost w to this graph 
             (->dm ((from node?) 
                    (w (cost/c (get-field low-cost this) (get-field high-cost this)))
                    (to node?))
                   #:pre (triangle-condition-preserved (send this edges) from w to)
                   any)))
   (reverse-edges
    ;; reverse all edges in this graph, keep costs 
    (->m any))
   (join 
    ;; join the nodes of other graph to this graph 
    (->dm ((other (instanceof/c graph/c)))
          #:pre (and (set=? (set-intersect (send this nodes) (send other nodes)) (seteq))
                     (= (get-field low-cost this) (get-field low-cost other))
                     (= (get-field high-cost this) (get-field high-cost other)))
          any))
   (path? 
    ;; is there a path from f to t? 
    (->dm ((f node?) (t node?)) (result boolean?)))
   (path
    ;; (path f t) is there a path from f to t and its total cost in this graph 
    (->dm ((f node?) (t node?)) #:pre (send this path? f t)
          (values (cost real?) (p (listof edge?)))))))

;; [set/c edge?] node? real? node? -> boolean? 
;; does the new edge preserve all new triangle equations? 
(define (triangle-condition-preserved edges:set from cost-from->to to)
  (define edges (set->list edges:set))
  (define to-out (filter (λ (e) (and (eq? (edge-from e) to) (not (eq? (edge-to e) from)))) edges))
  (define to-in (filter (λ (e) (and (eq? (edge-to e) to) (not (eq? (edge-from e) from)))) edges))
  (define (edges-between s t) 
    (filter (λ (e) (and (eq? (edge-from e) s) (eq? (edge-to e) t))) edges))
  (and 
   ;       from              to
   ;         *----- cost---->* 
   ;                         |
   ;                         | 
   ;                         |
   ;                         v
   ;                         * target 
   ;; there is only one way to complete this triangle: from->target
   (for/and ((to->target to-out))
     (define cost-from->to->target (+ cost-from->to (edge-cost to->target)))
     (for/and ((from->target (edges-between from (edge-to to->target))))
       (define cost-from->target (edge-cost from->target))
       (<= cost-from->target cost-from->to->target)))
   ;       from              to
   ;         *----- cost --->* 
   ;                         ^
   ;                         | 
   ;                         |
   ;                         |
   ;                         * intermediate 
   ;; there are two ways to complete this triangle: from -> intermediate, intermediate -> from
   (for/and ((intermediate->to to-in))
     (define cost-intermediate->to (edge-cost intermediate->to))
     (define intermediate (edge-from intermediate->to))
     (and 
      (for/and ((intermediate-from (edges-between intermediate from)))
        (define cost-intermediate->from (edge-cost intermediate-from))
        (<= cost-intermediate->to (+ cost-intermediate->from cost-from->to)))
      (for/and ((from->intermediate (edges-between from intermediate)))
        (define cost-from->intermediate (edge-cost from->intermediate))
        (<= cost-from->to (+ cost-from->intermediate cost-intermediate->to)))))))