gistfile1.txt

gosh> (load "./graph-examples")
(:-> "The Magic Flute" "Mozart" "composer")(:-< "Mozart" "The Magic Flute" "compose")

(:-< 私 手鏡 持つ)(:-> 私 手鏡 見る)

(:-> "hogehoge.pdf" "ほげほげについての一考察" Title)(:-> "hogehoge.pdf" "ふむ,ふむん" Author)

(:-> "The Magic Flute" "Mozart" "composer")(:-< "Mozart" "The Magic Flute" "compose")

#t

graph-examples.scm

(use graph)

;GIST
; graph module
;   https://gist.github.com/yamasushi/e89e461d754dfad1b43d

(graph-for-each write
  (make-graph
    (>- "The Magic Flute" "Mozart" "compose")
    (-> "The Magic Flute" "Mozart" "composer") ) )
(print "\n")

(graph-for-each write
  ( make-graph
    (-< '私 '手鏡 '持つ)
    (-> '私 '手鏡 '見る) ) )
(print "\n")

(graph-for-each write
  ( make-graph
    (-> "hogehoge.pdf" "ほげほげについての一考察" 'Title)
    (-> "hogehoge.pdf" "ふむ,ふむん" 'Author ) ) )
(print "\n")

(graph-for-each write
  ( make-graph
    (-@< "Mozart" "compose" "The Magic Flute")
    (-@> "The Magic Flute" "composer" "Mozart" ) ) )
(print "\n")

graph.scm

;; graph
(define-module graph
  (use srfi-113)
  (use srfi-13)
  (use text.tr)
  (export
    >- -> >-> ->-
    -< <- <-< -<-
    >@- -@> -@< <@-
    >-< <-> -<>- -><-
    <> >> <<
    make-graph
    graph-unfold
    graph-contains?
    graph-adjoin
    graph-delete
    graph-delete-all
    graph-adjoin!
    graph-delete!
    graph-delete-all!
    graph->list
    list->graph
    graph-map
    graph-for-each
    graph-fold
    graph-filter)
     )
(select-module graph)

;GIST
; https://gist.github.com/yamasushi/e89e461d754dfad1b43d

; graph
; graph を三項述語として捉える

; 3項述語
; >- , -> , >-> , ->-
; ex)
; x->y (t
;  == (-> x y t)
; x-<y (t
;  == (-< x y t)
; ...
;順番を変えることができる
;x->y ==> y<-x ( same t
;(-> x y t) == (<- y x t)

(define-macro (%defg% op)
  (let1 rev ($ string->symbol
             $ string-tr ($ string-reverse $ symbol->string op) "<>" "><")
    `(begin
      (define (,op x y :optional (t #f) )
        (list ,(make-keyword op) x y t))
      (define (,rev x y :optional (t #f) )
        (list ,(make-keyword op) y x t))
      ) ) )

(define-macro (%defg-mt% op rec)
  (let1 rev ($ string->symbol
             $ string-tr ($ string-reverse $ symbol->string op) "<>" "><")
    `(begin
      (define (,op x t y)
        (list ,(make-keyword rec) x y t))
      (define (,rev x t y)
        (list ,(make-keyword rec) y x t))
      ) ) )


(%defg% -< )
(%defg% -> )
(%defg% >-> )
(%defg% ->- )

; middle tag format
(%defg-mt% -@< -<)
(%defg-mt% -@> ->)

; 対称述語
; >-< , <->
; -<>- , -><-
(define-macro (%defg-sym% op)
  `(define (,op x y t)
      (if (> (hash x) (hash y) )
        (list ,(make-keyword op) x y t)
        (list ,(make-keyword op) y x t) ) ) )
(%defg-sym% >-<)
(%defg-sym% <->)
(%defg-sym% -><-)
(%defg-sym% -<>-)

; comparator
(define (%make-graph-comparator)
  (make-comparator
    (^x
        ;#?=x
        (and
          (list? x)
          (keyword? (car x) )
          (>= (length x) 4 )  ) )
    equal?
    #f ; no compare
    hash
  ) )

; container
; <> ..... bag(multiset)
; >>,<< vector

(define <> (pa$ bag equal-comparator))
(define >> vector)
(define (<< . x) (apply vector (reverse x)))

; make
(define (make-graph . elts)
  (apply set (cons (%make-graph-comparator) elts) ) )

; graph-unfold stop? mapper successor seed
(define (graph-unfold stop? mapper successor seed)
  (set-unfold
    stop? mapper successor seed (%make-graph-comparator) ))

; predicates
(define graph-contains? set-contains?)

; updaters
(define graph-adjoin set-adjoin)
(define graph-delete set-delete)
(define graph-delete-all set-delete-all)

(define graph-adjoin! set-adjoin!)
(define graph-delete! set-delete!)
(define graph-delete-all! set-delete-all!)

; conversion
(define graph->list set->list)
(define list->graph (pa$ list->set (%make-graph-comparator) ) )

; operation

; (graph-map proc graph)
(define graph-map (pa$ set-map (%make-graph-comparator)) )

; (graph-for-each proc graph)
(define graph-for-each set-for-each)

; (graph-fold proc seed graph)
(define graph-fold set-fold)

; (graph-filter pred graph)
(define graph-filter set-filter)