Welcome to the CHICKEN Scheme pasting service

(use extras srfi-69 srfi-1)

;; Conventions:
;; nht = nested hash tables implementation
;; The nodes are stored as keys in a hash-table. The hash-table values are hash-tables that 
;; as keys hold other nodes number (and this forms an edge) and as values hold edge properties.

;; lht = list in hash table implementation
;; The nodes are also stored as keys in a hash-table. The hash-table values are alists which
;; hold as the car of each sublist other nodes number (so forming edges) and as the cdr
;; edge properties.

;; s-node = source node (of edge)
;; d-node = destination node (of edge)

(define (lht-graph)
  (define g (make-hash-table))

  (define (id) "List in hash-table")
  
  (define (add-edge! s-node d-node #!optional (property 'none))
    (hash-table-update!/default g
                                s-node
                                (lambda (v)
                                  (cons (cons d-node property) v))
                                (list (cons d-node property))))

  (define (remove-edge! s-node d-node)
    (let ((edges (hash-table-ref/default g s-node #f)))
      (if edges
          (delete! d-node edges))))

  (define (has-node? node)
    (hash-table-exists? g node))
  
  (define (has-edge? s-node d-node)
    (member d-node (hash-table-ref/default g s-node '())))

  (define (graph->alist)
    (hash-table-map g (lambda(k v)
                        (cons k v))))

  (define (serialize #!optional (file "graph.txt"))
    (with-output-to-file file (lambda ()
                                (pp (graph->alist)))))

  (define (unserialize #!optional (file "graph.txt"))
    (with-input-from-file file (lambda ()
                                (set! g (alist->hash-table (read))))))
  
  ;; Dispatcher
  (lambda (selector)
    (case selector
      ((id)                id)
      ;;((add-node!)         add-node!)
      ((add-edge!)         add-edge!)
      ((remove-edge!)      remove-edge!)
      ((has-edge?)         has-edge?)
      ((has-node?)         has-node?)
      ((graph->alist)      graph->alist)
      ((serialize)         serialize)
      ((unserialize)       unserialize)
      (else (error "Uknown procedure")))))

(define (nht-graph)
  (define g (make-hash-table))
  
  (define (id) "Nested hash-tables")

  (define (add-edge! s-node d-node #!optional (property 'none))
    (let ((edges (hash-table-ref/default g s-node #f)))
      (if edges
          (hash-table-set! edges d-node property)
          (hash-table-set! g
                           s-node
                           (alist->hash-table `((,d-node . ,property)))))))

  (define (remove-edge! s-node d-node)
    (let ((edges (hash-table-ref/default g s-node #f)))
      (if edges
          (hash-table-delete! edges d-node)
          #f)))

  (define (has-node? node)
    (hash-table-exists? g node))

  (define (has-edge? s-node d-node)
    (let ((edges (hash-table-ref/default g s-node #f)))
      (if edges
          (hash-table-exists? edges d-node)
          #f)))

  (define (graph->alist)
    (hash-table-map g (lambda(k v)
                        (cons k (hash-table->alist v)))))

 (define (serialize #!optional (file "graph.txt"))
  (with-output-to-file file (lambda ()
                              (pp (graph->alist)))))

  ;; Dispatcher
  (lambda (selector)
    (case selector
      ((id)                id)
      ;;((add-node!)         add-node!)
      ((add-edge!)         add-edge!)
      ((remove-edge!)      remove-edge!)
      ((has-edge?)         has-edge?)
      ((has-node?)         has-node?)
      ((graph->alist)      graph->alist)
      ((serialize)         serialize)
      (else (error "Uknown procedure")))))

(define (make-graph #!optional (impl 'lht))
  (case impl
    ((lht)     (lht-graph))
    ((nht)     (nht-graph))))


;; Test case
(define VERTEXES 2500)
(define EDGES 1000)

(define (add-edges g)
  (printf "~N Adding edges (~A)~N" ((g 'id)))
  (do ((n 0 (+ n 1))) ((= n VERTEXES))
    (do ((e 0 (+ e 1))) ((= e EDGES))
      ((g 'add-edge!) n (+ e 1)))))

(define (del-edges g)
  (printf "~N Removing edges (~A)~N" ((g 'id)))  
  (do ((n 0 (+ n 1))) ((= n VERTEXES))
    (do ((e 0 (+ e 1))) ((= e EDGES))
      ((g 'remove-edge!) n (+ e 1)))))

(define (check-nodes g)
  (printf "~N Checking nodes (~A)~N" ((g 'id)))  
  (do ((n 0 (+ n 1))) ((= n VERTEXES))
    (g 'has-node?) n))

(define (check-edges g)
  (printf "~N Checking edges (~A)~N" ((g 'id)))  
  (do ((n 0 (+ n 1))) ((= n VERTEXES))
    (do ((e 0 (+ e 1))) ((= e EDGES))
      ((g 'has-edge?) n (+ e 1)))))

(define (serialize-to-file g)
  (printf "~N Serializing to file (~A)~N" ((g 'id)))  
  ((g 'serialize)))

(define (unserialize-from-file g)
  (printf "~N Unserializing from file (~A)~N" ((g 'id)))  
  ((g 'unserialize)))

(define (run-test graph)
  (time (add-edges graph))
;;  (pp ((graph 'graph->alist)))
  (time (serialize-to-file graph))
  (time (unserialize-from-file graph))
  ;; (time (check-nodes graph))
  ;; (time (check-edges graph))
  ;; (time (del-edges graph)))
  )
(define lht-graph (make-graph 'lht))
(define nht-graph (make-graph 'nht))

(run-test lht-graph)
(printf "~N-----------------------------------------------------------------~N")
(run-test nht-graph)