graph.scm

; https://gist.github.com/yamasushi/d65c1549d7ac8124340ff915f5a5a08b

(use scheme.list)
(use util.match)

(define not-list? (.$ not list?))

(define triple
  (.$
   concatenate
   (pa$ map
       (match-lambda
        [ [(? not-list? x) (? not-list? y) (? not-list? z)] (list (list x y z))]
        [ [(? list? xs) y z] (map (^x (list x y z)) xs ) ] 
        [ [x (? list? ys) z] (map (^y (list x y z)) ys ) ] 
        [ [x y (? list? zs)] (map (^z (list x y z)) zs ) ] )) ) )
  
; gosh$ (triple '( (1 (222 222) 3) ((1 111 1111) 2 3) (1 2 (333 333 333))))
; ((1 222 3) (1 222 3) (1 2 3) (111 2 3) (1111 2 3) (1 2 333) (1 2 333) (1 2 333))

; gosh$ (triple '( (1 (222 222) 3) ((1 111 1111) 2 3) (1 2 (333 333 333)) (4 5 6) ))
; ((1 222 3) (1 222 3) (1 2 3) (111 2 3) (1111 2 3) (1 2 333) (1 2 333) (1 2 333)
; (4 5 6))


(define (-> e n) `(,e -> ,n) )
(define (<- n e) `(,e -> ,n) )
(define (-< e n) `(,e -< ,n) )
(define (>- n e) `(,e -< ,n) )

(define (>--> x e y) `(,(>- x e) ,(-> e y) ) )
(define (<--< y e x) (>--> x e y))

; gosh$ `(,(>--> 1 '(2 3 4) 3) ,(>--> 3 5 7))
; (((-< (2 3 4) 1) (-> (2 3 4) 3)) ((-< 5 3) (-> 5 7)))
; gosh$ (concatenate `(,(>--> 1 '(2 3 4) 3) ,(>--> 3 5 7)))
; ((-< (2 3 4) 1) (-> (2 3 4) 3) (-< 5 3) (-> 5 7))

; lmr = (l m r)
(define (l->mr g pred-l)
  (filter-map (match-lambda
               [ [(? pred-l) m r] (list m r) ]
               [ _ #f ] ) g ) )

(define (r->lm g pred-r)
  (filter-map (match-lambda
               [ [l m (? pred-r)] (list l m) ]
               [ _ #f ] ) g ) )

(define (m->lr g pred-m)
  (filter-map (match-lambda
               [ [l (? pred-m) r] (list l r) ]
               [ _ #f ] ) g ) )


(define (lm->r g pred-l pred-m)
  (filter-map (match-lambda
               [ [(? pred-l) (? pred-m) r] r ]
               [ _ #f ] ) g ) )

(define (mr->l g pred-m pred-r)
  (filter-map (match-lambda
               [ [l (? pred-m) (? pred-r)] l ]
               [ _ #f ] ) g ) )

(define (lr->m g pred-l pred-r)
  (filter-map (match-lambda
               [ [(? pred-l) m (? pred-r)] m ]
               [ _ #f ] ) g ) )

(define (mrmr->l g m1 r1 m2 r2)
  (lset-intersection equal?
                     (mr->l g (pa$ equal? m1) (pa$ equal? r1))
                     (mr->l g (pa$ equal? m2) (pa$ equal? r2))))

(define (vv->e g v1 v2)
  (mrmr->l g '-< v1 '-> v2))

(define (left l . mrs)
  (filter-map (match-lambda
               [[m r] (list l m r) ]
               [_ #f] ) mrs ) )

(define (middle m . lrs)
  (filter-map (match-lambda
               [[l r] (list l m r) ]
               [_ #f] ) lrs ) )

(define (right r . lms)
  (filter-map (match-lambda
               [[l m] (list l m r) ]
               [_ #f] ) lms ) )


(define ev->m lr->m)

(define alist->graph 
  ($ concatenate $ map (^x (>--> (car x) x (cdr x))) $) )