graph-alg.lisp

;; Alghoritm to searching subgraph in graph
;; rewrite:
;; (get-v-outs graph vertex)
;; (same-vertex? v1 v2)

(load "pscat.lisp")

(defpackage graph-alg
  (:use :cl :pscat))

(in-package graph-alg)

;; #################################
;; generic functions to work with graphs
(defgeneric verticies (graph))

(defgeneric get-v-outs (graph vertex))

(defgeneric same-vertex? (v1 v2))


;; #################################
;; simply graph system
(defstruct (simply-graph (:constructor make-simply-graph ())
             (:conc-name simply-graph-))
  (verticies nil)
  (branchs nil))

;; Methods to special cases
(defmethod verticies ((graph simply-graph))
  (simply-graph-verticies graph))

(defmethod get-v-outs ((graph simply-graph) vertex)
  (with-slots (branchs) graph
    (loop for branch in branchs
       with result = (list)
       do (multiple-value-bind (el id)
          (pscat:list-find-and-id vertex branch)
        (if el
        (if (> id 0)
            (push (car branch) result)
            (setf result (append result (cdr branch))))))
       finally (return (delete-duplicates result)))))

(defmethod same-vertex? ((v1 symbol) (v2 symbol))
  (equal v1 v2))

;; Testing
(defparameter *sg-g* (let ((sg (make-simply-graph))
               (g (make-simply-graph)))
               (setf (simply-graph-verticies sg) '(a b c))
               (setf (simply-graph-verticies g) '(a b c d))
               (setf (simply-graph-branchs sg) '((a b c) (b a)))
               (setf (simply-graph-branchs g) '((a d) (a b c)))
               (cons sg g)))


;; #################################
;; To save subgraph variants
(defstruct (variant (:constructor make-variant)
            (:conc-name variant-))
  pairs)


;; #################################
;; Searching
(defun search-subgraph-in-graph (subgraph graph)
  (let ((all-variants '()))
    (labels ((search-iter (subgraph-vertex graph-vertex)
           (let ((subgraph-v-out-vs (get-v-outs subgraph subgraph-vertex))
             (graph-v-out-vs (get-v-outs graph graph-vertex)))
         (let* ((interception (get-interception subgraph-v-out-vs graph-v-out-vs #'same-vertex?))
            (alls-next-paths (set-product (mapcar #'cdr interception))))

           ;; all vertexes in subgraph and graph that go in one vertex on next level
           (print (vertexes-that-go-in-one-on-next-level subgraph subgraph-v-out-vs #'same-vertex?))
           (print (vertexes-that-go-in-one-on-next-level graph graph-v-out-vs #'same-vertex?))
           ))))
      (loop for sv in (verticies subgraph)
     do (loop for v in (verticies graph)
           do (when (same-vertex? v sv)
            (search-iter sv v)))))))


(defun get-interception (l1 l2 &optional (equalp #'equalp))
  ;;conformuty between graph and subgrap vertexies
  (loop for el1 in l1
     with interceptions
     do (loop for el2 in l2
       when (funcall equalp el2 el1) collect el2 into accum
       finally (when accum
             (push (cons el1 accum) interceptions)))
     finally (return interceptions)))

(defun vertexes-that-go-in-one-on-next-level (graph vertexes &optional (equalp #'equalp))
  (loop for v in vertexes
     collect (cons v (get-v-outs graph v)) into accum
     finally (lists-with-commons accum equalp)))

(defun lists-with-commons (ls &optional (equalp #'equalp))
  (loop for l1 in ls
     for i from 1
     with ls-with-common-els
     do (loop for l2 in (subseq ls i)
       when (get-interception (cdr l1) (cdr l2) equalp)
       do (push (cons (car l1) (car l2)) ls-with-common-els))
     finally (return ls-with-common-els)))

(defun set-product (ls)
  (labels ((set-iter (set ls)
         (if ls
         (set-iter (product set (car ls)) (cdr ls))
         set))
       (product (set l)
         (loop for el in l
        append (loop for s in set
              for s-list = (in-list s)
              collect (cons el s-list)))))
    (set-iter (car ls) (cdr ls))))

(defun in-list (l)
  (if (listp l) l (list l)))