;;;; graph.scm --- minimal graph module for Guile
;;;;
;;;; Copyright (C) 2016 Amirouche Boubekki <address@hidden>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (graph))

(use-modules (srfi srfi-9))
(use-modules (srfi srfi-26))
(use-modules (srfi srfi-69))

(use-modules (ice-9 q))

;;; generate-uid helper

(define-public (generate-uid exists?)
  "Generate a random string made up alphanumeric ascii chars that doesn't exists
   according to `exists?`"
  (define (random-id)
    (define CHARS "0123456789AZERTYUIOPQSDFGHJKLMWXCVBN")
    ;; append 8 alphanumeric chars from `CHARS`
    (let loop ((count 8)
               (id ""))
      (if (eq? count 0)
          id
          (loop (1- count) (format #f "~a~a" id (string-ref CHARS (random 36)))))))

  (let loop ()
    ;; generate a random uid until it find an id that doesn't already exists?
    (let ((id (random-id)))
      (if (exists? id) (loop) id))))


;;; graph

(define-record-type <graph>
  (%make-graph name properties vertices edges)
  graph?
  (name graph-name)
  (properties graph-properties)
  (vertices graph-vertices)
  (edges graph-edges))


(define-public (make-graph name)
  (%make-graph name (make-hash-table) (make-hash-table) (make-hash-table)))

(define-public (graph-ref graph key)
  (hash-table-ref (graph-properties graph) key))

(define-public (graph-set! graph key value)
  (hash-table-set! (graph-properties graph) key value))

(define-public (graph-vertex-ref graph uid)
  (hash-table-ref (graph-vertices graph) uid (lambda () #false)))

(define-public (graph-edge-ref graph uid)
  (hash-table-ref (graph-edges graph) uid (lambda () #false)))

(define-public (graph-for-each-vertex graph proc)
  (for-each proc (hash-table-values (graph-vertices graph))))


;;; vertex

(define-record-type <vertex>
  (make-vertex graph uid incomings properties outgoings)
  vertex?
  (graph vertex-graph)
  (uid vertex-uid)
  (incomings vertex-incomings vertex-incomings!)
  (properties vertex-properties)
  (outgoings vertex-outgoings vertex-outgoings!))

(define-public (graph-make-vertex graph)
  (let* ((uid (generate-uid (cut graph-vertex-ref graph <>)))
         (vertex (make-vertex graph uid '() (make-hash-table) '())))
    (hash-table-set! (graph-vertices graph) uid vertex)
    vertex))

(define-public (vertex-ref vertex key)
  (hash-table-ref (vertex-properties vertex) key))

(define-public (vertex-set! vertex key value)
  (hash-table-set! (vertex-properties vertex) key value))


;;; edge

(define-record-type <edge>
  (make-edge graph uid start properties end)
  edge?
  (graph edge-graph)
  (uid edge-uid)
  (start edge-start edge-start!)
  (properties edge-properties)
  (end edge-end edge-end!))


(define-public (graph-make-edge graph start end)
  (let* ((uid (generate-uid (cut graph-edge-ref graph <>)))
         (edge (make-edge graph uid (vertex-uid start) (make-hash-table) (vertex-uid end))))
    ;; add to graph
    (hash-table-set! (graph-edges graph) uid edge)
    ;; update start vertex
    (vertex-outgoings! start (cons uid (vertex-outgoings start)))
    ;; update end vertex
    (vertex-incomings! end (cons uid (vertex-incomings end)))
    edge))

(define-public (edge-ref edge key)
  (hash-table-ref (edge-properties edge) key))

(define-public (edge-set! edge key value)
  (hash-table-set! (edge-properties edge) key value))

(define-public (edge-delete! edge)
  (let ((graph (edge-graph edge)))
    (hash-table-delete! (graph-edges graph) (edge-uid edge)))
  (let* ((uid (edge-start edge))
         (start (graph-vertex-ref (edge-graph edge) uid)))
    (vertex-outgoings! start (delete (edge-uid edge) (vertex-outgoings start))))
  (let* ((uid (edge-end edge))
         (end (graph-vertex-ref (edge-graph edge) uid)))
    (vertex-incomings! end (delete (edge-uid edge) (vertex-incomings end)))))


;;; helpers

(define-public (vertex-adjacents vertex)
  (let* ((ref-edge (cut graph-edge-ref (vertex-graph vertex) <>)))
    (append (map (compose edge-end ref-edge) (vertex-outgoings vertex))
            (map (compose edge-start ref-edge) (vertex-incomings vertex)))))


;;; algorithms

;; sanitize names of queue procedure
(define make-queue make-q)
(define enqueue! enq!)
(define dequeue! deq!)
(define queue-empty? q-empty?)


(define-public (bfs proc graph root)
  (let ((queue (make-queue))
        (visited (make-hash-table)))

    (hash-table-set! visited root #true)
    (enqueue! queue root)

    (proc root)

    (while (not (queue-empty? queue))
      (let ((current (dequeue! queue)))
        (let next ((adjacents (vertex-adjacents current)))
          (unless (null? adjacents)
            (let ((adjacent (graph-vertex-ref graph (car adjacents))))
              (unless (hash-table-ref visited adjacent (lambda () #false))
                (proc adjacent)
                (hash-table-set! visited adjacent #true)
                (enqueue! queue adjacent)
                (next (cdr adjacents))))))))))



;;; test-check

(define-syntax test-check
  (syntax-rules ()
    ((_ title tested-expression expected-result)
     (begin
       (format #true "* Checking ~s\n" title)
       (let* ((expected expected-result)
              (produced tested-expression))
         (unless (equal? expected produced)
             (format #true "Expected: ~s\n" expected)
             (format #true "Computed: ~s\n" produced)))))))

(when (getenv "CHECK")
  (test-check "null test"
              #true
              #true)

  (test-check "graph get/set properties"
              (let ((graph (make-graph "test")))
                (graph-set! graph "key" "value")
                (graph-ref graph "key"))
              "value")

  (test-check "graph-make-vertex"
              (let* ((graph (make-graph "test"))
                     (vertex (graph-make-vertex graph)))
                (vertex-uid vertex))
              "I5QBE2X7")

  (test-check "graph-vertex-ref"
              (let* ((graph (make-graph "test"))
                     (vertex (graph-make-vertex graph)))
                (vertex-uid (graph-vertex-ref graph (vertex-uid vertex))))
              "ACNEG5QH")

  (test-check "vertex get/set properties"
              (let* ((graph (make-graph "test"))
                     (vertex (graph-make-vertex graph)))
                (vertex-set! vertex "key" "value")
                (vertex-ref vertex "key"))
              "value")

  (test-check "graph-make-edge"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (edge-uid edge))
              "FJC4FXVX")

  (test-check "graph-edge-ref"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (edge-uid (graph-edge-ref graph (edge-uid edge))))
              "6D8CT84K")

  (test-check "edge get/set"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (edge-set! edge 'key 'value)
                (edge-ref edge 'key))
              'value)

  (test-check "make edge and check start outgoings"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (vertex-outgoings start))
              '("CGUE4JQX"))

  (test-check "make edge and check end incomings"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (vertex-incomings end))
              '("FJUX0J70"))

  (test-check "make edge, delete and check start outgoings"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (edge-delete! edge)
                (map edge-uid (vertex-outgoings start)))
              '())

  (test-check "make edge, delete and check end incomings"
              (let* ((graph (make-graph "test"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end)))
                (edge-delete! edge)
                (map edge-uid (vertex-incomings end)))
              '())

  (test-check "bfs 1"
              (let* ((graph (make-graph "test bfs"))
                     (start (graph-make-vertex graph))
                     (end (graph-make-vertex graph))
                     (edge (graph-make-edge graph start end))
                     (out '()))
                (bfs (lambda (vertex)
                       (set! out (cons (vertex-uid vertex) out)))
                     graph
                     start)
                out)
              '("BFGONU27" "3U0FOZ3S"))

  (test-check "bfs 2"
              (let* ((graph (make-graph "test bfs"))
                     (one (graph-make-vertex graph))
                     (two (graph-make-vertex graph))
                     (three (graph-make-vertex graph))
                     (four (graph-make-vertex graph))
                     (_ (graph-make-edge graph one two))
                     (_ (graph-make-edge graph two three))
                     (_ (graph-make-edge graph three one))
                     (_ (graph-make-edge graph three four))
                     (out '()))
                (bfs (lambda (vertex)
                       (set! out (cons (vertex-uid vertex) out)))
                     graph
                     one)
                out)
              '("DFE8JJFG" "BVD4NBDB" "KBBT34AA" "PTUMTLV4"))
  )