bug#58198: topological-sort does not sort topologically in case of diamonds

bug#58198: topological-sort does not sort topologically in case of diamonds

[Maxime Devos]

[-- Attachment #1.1.1: Type: text/plain, Size: 2511 bytes --]

Consider the following DAG (arrows are implicitly downwards):

top -> left, right
left,right -> bottom.

Or in ASCII art:

      top
     /    \
left      right
     \    /
      bottom

Currently, they are sorted incorrectly with topological-sort -- the 
exact resulting order depends on the order in which the dependencies are 
passed to 'topological-sort' (from (guix import utils)), but you can get 
the following:

right bottom left top

'bottom' and 'right' need to be switched.

(Background)
I would like to use a copy of 'topological-sort' for determining the 
order in which 'workspace' members need to be built in antioxidant, but 
currently it produces bogus results (at least for 'greetd').

Theoretically, it would also impact recursive imports (unverified) 
(topological-sort is used to emit them in topological order).

Code to reproduce the bug:

(use-modules (guix sets) (ice-9 match) (srfi srfi-1))

(define (topological-sort nodes
                           node-dependencies
                           node-name)
   "Perform a breadth-first traversal of the graph rooted at NODES, a 
list of
nodes, and return the list of nodes sorted in topological order.  Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
   (let loop ((nodes nodes)
              (result '())
              (visited (set)))
     (match nodes
       (()
        result)
       ((head . tail)
        (if (set-contains? visited (node-name head))
            (loop tail result visited)
            (let ((dependencies (node-dependencies head)))
              (loop (append dependencies tail)
                    (cons head result)
                    (set-insert (node-name head) visited))))))))

(define %dependencies
   '((top left right)
     (left bottom)
     (right bottom)
     (bottom)))
(define root-nodes '(top))
(define (node-dependencies node)
   (assoc-ref %dependencies node))
(define node-name identity)
(define sorted (topological-sort root-nodes node-dependencies node-name))
(write sorted)

;; Verify the dependencies have smaller indices
(define (node-index node)
   (list-index (lambda (x) (equal? node x)) sorted))
(define (check node)
   (unless (<= (apply max 0 (map node-index (node-dependencies node)))
	      (node-index node))
     (pk node)
     (error "incorrectly sorted!")))
(for-each check (map car %dependencies))


Greetings,
Maxime.

[-- Attachment #1.1.2: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

bug#58198: topological-sort does not sort topologically in case of diamonds

[Maxime Devos]

[-- Attachment #1.1.1: Type: text/plain, Size: 127 bytes --]

Currently trying out https://srfi.schemers.org/srfi-234/srfi-234.html, 
let's see how that works out.

Greetings,
Maixme.

[-- Attachment #1.1.2: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

bug#58198: topological-sort does not sort topologically in case of diamonds

[Maxime Devos]

[-- Attachment #1.1.1: Type: text/plain, Size: 377 bytes --]

I found a solution: change the depth-first traversal to a breadth-first 
traversal -- it uses (pfds hamts) from guile-pfds instead of (guix 
sets)/(ice-9 vlist), so will need some small changes for use in Guix 
(unless the additional dependency is considered acceptable), but it 
should at least unblock the workspace implementation in antioxidant.

Greetings,
Maxime.

[-- Attachment #1.1.2: topological-sort.scm --]
[-- Type: text/x-scheme, Size: 2812 bytes --]

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;; To be used by the implementation of workspaces.
;; Extracted from (guix import utils), and changed from (guix sets)
;; to a guile-pfds equivalent.
(define-module (topological-sort)
  #:export (topological-sort)
  #:use-module ((srfi srfi-69) #:select (hash))
  #:use-module ((ice-9 match) #:select (match))
  #:use-module (pfds hamts))

(define (topological-sort nodes
                          node-dependencies
                          node-name)
  "Perform a breadth-first traversal of the graph rooted at NODES, a list of
nodes, and return the list of nodes sorted in topological order.  Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
  ;; It is important to do a breadth-first traversal instead of a depth-first
  ;; traversal -- a simpler depth-first traversal has caused failures in the
  ;; past.
  (let loop ((unexpanded-nodes nodes)
	     (result '()) ; in reverse topological order
	     ;; Identical to 'result', except for using a different data
	     ;; structure.
	     (visited (make-hamt hash equal?)))
    (if (null? unexpanded-nodes)
	(reverse result) ; done!
	(let inner-loop ((current-unexpanded-nodes unexpanded-nodes)
			 (later-unexpanded-nodes '())
			 (result result)
			 (visited visited))
	  (match current-unexpanded-nodes
	    ((first . current-unexpanded-nodes)
	     (if (hamt-ref visited (node-name first) #false)
		 ;; Already visisted, nothing to do!
		 (inner-loop current-unexpanded-nodes
			     later-unexpanded-nodes result visited)
		 ;; Expand 'first', putting dependencies in
		 ;; 'later-unexpanded-nodes'.
		 (inner-loop current-unexpanded-nodes
			     (append (node-dependencies first)
				     later-unexpanded-nodes)
			     (cons first result)
			     (hamt-set visited (node-name first) #true))))
	    (() ;; All nodes on the current level are expanded, descend!
	     (loop later-unexpanded-nodes result visited)))))))

[-- Attachment #1.1.3: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

bug#58198: topological-sort does not sort topologically in case of diamonds

[Maxime Devos]

[-- Attachment #1.1.1: Type: text/plain, Size: 239 bytes --]



On 08-10-2022 20:13, Maxime Devos wrote:
> I found a solution: [...]

It's buggy, it doesn't handle situations like

	    libnewsboat
	  /   |
	 |  regex-rs
          |    |
         strprintf.

Revised module is attached.

[-- Attachment #1.1.2: topological-sort.scm --]
[-- Type: text/x-scheme, Size: 4339 bytes --]

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;; To be used by the implementation of workspaces.
;; Extracted from (guix import utils), and changed from (guix sets)
;; to a guile-pfds equivalent.
(define-module (topological-sort)
  #:export (topological-sort topological-sort*)
  #:use-module (srfi srfi-1)
  #:use-module ((srfi srfi-69) #:select (hash))
  #:use-module ((ice-9 match) #:select (match))
  ;; XXX: Cuirass compiles even build-side only modules.
  #:autoload (pfds hamts) (make-hamt hamt-ref hamt-set))

(define (topological-sort nodes
                          node-dependencies
                          node-name)
  "Perform a breadth-first traversal of the graph rooted at NODES, a list of
nodes, and return the list of nodes sorted in topological order.  Call
NODE-DEPENDENCIES to obtain the dependencies of a node, and NODE-NAME to
obtain a node's uniquely identifying \"key\"."
  ;; It is important to do a breadth-first traversal instead of a depth-first
  ;; traversal -- a simpler depth-first traversal has caused failures in the
  ;; past.
  (define (is-dependency? potential-dependency potential-dependents)
    (member (node-name potential-dependency)
	    (map node-name
		 (append-map node-dependencies potential-dependents))))
  (let loop ((unexpanded-nodes nodes)
	     (result '()) ; in reverse topological order
	     ;; Identical to 'result', except for using a different data
	     ;; structure.
	     (visited (make-hamt hash equal?)))
    (if (null? unexpanded-nodes)
	(reverse result) ; done!
	(let inner-loop ((current-unexpanded-nodes unexpanded-nodes)
			 (later-unexpanded-nodes '())
			 (result result)
			 (visited visited)
			 (progress? #false))
	  (match current-unexpanded-nodes
	    ((first . current-unexpanded-nodes)
	     (cond ((hamt-ref visited (node-name first) #false)
		    ;; Already visisted, nothing to do!
		    (inner-loop current-unexpanded-nodes
				later-unexpanded-nodes result visited
				#true))
		   ;; XXX: would be nice to not recompute
		   ;; 'node-dependencies'.
		   ((is-dependency? first current-unexpanded-nodes)
		    ;; The node was a dependency of something on the previous
		    ;; level, but also of something of the current level.
		    ;; Delay it for later.
		    (inner-loop current-unexpanded-nodes
				(cons first later-unexpanded-nodes)
				result
				visited
				progress?))
		   (#true
		    ;; Expand 'first', putting dependencies in
		    ;; 'later-unexpanded-nodes'.
		    (inner-loop current-unexpanded-nodes
				(append (node-dependencies first)
					later-unexpanded-nodes)
				(cons first result)
				(hamt-set visited (node-name first) #true)
				#true))))
	    (()
	     ;; All nodes on the current level are expanded, descend!
	     ;; But first check for a cycle.
	     (if progress?
		 (loop later-unexpanded-nodes result visited)
		 (error "cycle"))))))))

(define (topological-sort* nodes node-dependencies node-name)
  "Like TOPOLOGICAL-SORT, but don't assume that NODES are roots.  Instead,
consider all nodes in the closure of NODES."
  (define artificial-root (make-symbol "root")) ; uninterned, fresh symbol
  (define nodes* (list artificial-root))
  (define (node-dependencies* node*)
    (if (eq? node* artificial-root)
	nodes
	(node-dependencies node*)))
  (define (node-name* node*)
    (if (eq? node* artificial-root)
	artificial-root
	(node-name node*)))
  (define (proper-node? node*)
    (not (eq? node* artificial-root)))
  (filter proper-node?
	  (topological-sort nodes* node-dependencies* node-name*)))

[-- Attachment #1.1.3: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]

bug#58198: topological-sort does not sort topologically in case of diamonds

[Maxime Devos]

[-- Attachment #1.1.1: Type: text/plain, Size: 159 bytes --]

The revised module is _also_ broken (in case of nushell's member graph). 
  Will wait with posting the revised² module until it has seen more 
testing ...

[-- Attachment #1.1.2: OpenPGP public key --]
[-- Type: application/pgp-keys, Size: 929 bytes --]

[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 236 bytes --]