permutations.rkt

#lang racket

(define (dict-order f)
  (λ (xs ys)
    (or (null? xs)
        (and (not (null? ys))
             (or (f (car xs) (car ys))
                 (and (equal? (car xs) (car ys))
                      (not (and (null? (cdr xs))
                                (null? (cdr ys))))
                      ((dict-order f) (cdr xs) (cdr ys))))))))

(define (perm-order x y)
  (cond
    [(and (number? x) (number? y)) (< x y)]
    [(and (list? x) (list? y)) ((dict-order perm-order) x y)]
    [else (error)]))

(define (minby proc ls)
  (cond
    [(null? (cdr ls)) (car ls)]
    [else (let ([x (car ls)]
                [rest (minby proc (cdr ls))])
            (if (proc x rest)
                x
                rest))]))

(define (normalize σ)
  (cond
    [(or (number? σ) (null? σ)) σ]
    [else (let* ([σ (map normalize σ)]
                 [m (minby perm-order σ)])
            (let-values ([(bef aft) (splitf-at σ (λ (x) (not (equal? x m))))])
              (append aft bef)))]))

(define (mk-perm . cycles)
  (normalize cycles))

(define (act-on σ n)
  (or (ormap (λ (cycle)
               (let ([c (member n cycle)])
                 (cond
                   [(not c) #f]
                   [(null? (cdr c)) (car cycle)]
                   [else (cadr c)])))
             σ) n))

(define test-σ (mk-perm '(1 2) '(3 5 4)))
(unless (and (equal? (act-on test-σ 1) 2)
             (equal? (act-on test-σ 2) 1)
             (equal? (act-on test-σ 3) 5)
             (equal? (act-on test-σ 5) 4)
             (equal? (act-on test-σ 4) 3))
  (error "act-on is broken"))

(define (elements σ)
  (foldl (λ (cycle acc) (set-union cycle acc)) null σ))

; assumes f is injective
; univ list
(define (proc->perm f univ)
  (normalize
   (foldl (λ (e acc)
            (if (findf (λ (cycle) (member e cycle)) acc)
                acc
                (letrec ([loop
                          (λ (curr)
                            (let ([next (f curr)])
                              (if (equal? e next)
                                  (list curr)
                                  (cons curr (loop next)))))]
                         [curr-cycle (loop e)])
                  (if (null? (cdr curr-cycle))
                      acc
                      (cons curr-cycle acc)))))
          null univ)))

(define (perm-comp σ τ)
  (proc->perm (λ (x) (act-on τ (act-on σ x)))
              (set-union (elements σ) (elements τ))))

(define (perm-inv σ)
  (map reverse σ))

(define S3
  (list (mk-perm)
        (mk-perm '(1 2))
        (mk-perm '(2 3))
        (mk-perm '(3 1))
        (mk-perm '(1 2 3))
        (mk-perm '(1 3 2))))

(define V4
  (list (mk-perm)
        (mk-perm '(1 3) '(2 4))
        (mk-perm '(1 4) '(2 3))
        (mk-perm '(1 2) '(3 4))))

; ordering is a permutation of the list V4
(define (S3-on-V4 ordering)
  (let ([num-to-V4 (λ (n) (list-ref ordering n))]
        [V4-to-num (λ (σ) (index-of ordering σ))])
    (λ (σ) (proc->perm (λ (τ) (num-to-V4 (act-on σ (V4-to-num τ))))
                       V4))))

; send `g` to `h -> ghg^{-1}`
(define (conjugation σ univ)
  (proc->perm (λ (τ) (perm-comp (perm-comp (perm-inv σ) τ) σ)) univ))

(define (perm-eq σ τ univ)
  (equal? (proc->perm (λ (x) (act-on σ x)) univ)
          (proc->perm (λ (x) (act-on τ x)) univ)))

(define cex-σ (mk-perm '(1 2)))

; converts σ ∈ Sn into its action on Sn, i.e. a permuatation in S(n!)
(define (embed-into-SSn σ univ)
  (proc->perm (λ (τ) (perm-comp σ τ)) univ))

(define (cycle-parity cycle)
  (remainder (add1 (length cycle)) 2))

(define (perm-parity σ)
  (remainder (apply + (map cycle-parity σ)) 2))

(when (= 1 (perm-parity (embed-into-SSn cex-σ S3)))
    "Counterexample found!")
(let ([ordering (findf (λ (ordering) (andmap (λ (σ) (equal? (conjugation σ V4) ((S3-on-V4 ordering) σ))) S3))
                       (map (λ (ls) (cons (mk-perm) ls)) (permutations (rest V4))))])
  (when ordering 
    (display "Ordering of V4 found: ")
    (displayln ordering)))