permute

[Ryan Davis]

Yes, I'm still obsessing...

(define (permute l1 l2)
(define (do-insert x y out)
(cond-e [(cons° x y out)]
[(fresh (y1 y2 z)
(cons° y1 y2 y)
(cons° y1 z out)
(do-insert x y2 z))]))

(cond-e [(fresh (x)
(cons° x '() l1)
(cons° x '() l2))]
[(fresh (x y z1)
(cons° x y l1)
(cond-a [(≈ y '()) %u]
[else %s])
(permute y z1)
(do-insert x z1 l2))]))

(module+ test
(require rackunit)
(require racket/list)
(require racket/set)

(let ([expected '((1 2 3 4) (2 1 3 4) (2 3 1 4) (2 3 4 1)
(1 3 2 4) (3 1 2 4) (3 2 1 4) (3 2 4 1)
(1 3 4 2) (3 1 4 2) (3 4 1 2) (3 4 2 1)
(1 2 4 3) (2 1 4 3) (2 4 1 3) (2 4 3 1)
(1 4 2 3) (4 1 2 3) (4 2 1 3) (4 2 3 1)
(1 4 3 2) (4 1 3 2) (4 3 1 2) (4 3 2 1))])

(check-true (set=?
(permutations '(1 2 3 4))
expected))

(check-run* (q)
(fresh (l1)
(≈ l1 '(1 2 3 4))
(permute l1 q))
=> expected)))

[Javier Soto]

Fun and different approach with condes brutally applied.

(define conde_list ; Given a value and a list of fresh vars, give me all combinations of value in list

  (lambda (val fl o)

    (fresh (x y a b)

      (conso a b o)

      (conso x y fl)

      (conde

        [(== val a) (== y b)]

        [(conde_list val y b)]))))

(define permuto

  (lambda (l o)

    (letrec

      ((freshlist (lambda (l o) ; make a twin list of fresh variables

                    (conde

                      [(nullo l) (nullo o)]

                      [(fresh (y b)

                         (cdro l y)

                         (cdro o b)

                         (freshlist y b))])))

       (condify (lambda (l fl o) ; conde for all vals of l in positions of fl

                  (conde

                    [(nullo l)]

                    [(fresh (x y)

                       (conso x y l)

                       (conde_list x fl o)

                       (condify y fl o))]))))

      (fresh (fl)

        (freshlist l fl)

        (condify l fl o)))))

(define expected

  (lambda ()

    '((1 2 3 4) (1 2 4 3) (1 3 2 4) (1 4 2 3) (1 3 4 2) (1 4 3 2)

      (2 1 3 4) (2 1 4 3) (3 1 2 4) (4 1 2 3) (3 1 4 2) (4 1 3 2)

      (2 3 1 4) (2 4 1 3) (3 2 1 4) (4 2 1 3) (3 4 1 2) (4 3 1 2)

      (2 3 4 1) (2 4 3 1) (3 2 4 1) (4 2 3 1) (3 4 2 1) (4 3 2 1))))

(check-true (set=? (permutations '(1 2 3 4)) (expected)))

[check-equal?

  (run* (q) (permuto '(1 2 3 4) q))

  (expected)]

[Javier Soto]

Holy shit! your version kicks ass in terms of speed!

I need to understand what you have done.

On Sunday, July 19, 2015 at 3:41:31 AM UTC-7, zenspider wrote:

[Scott Windsor]

very cool.

I moved to using cKanren to get =/= and was able to come up with a cleaner apartmento.

(define (aparmento floors)
(fresh (f1 f2 f3 f4 f5)
(== floors (list f1 f2 f3 f4 f5))
(memberso '(adam bill cora dale erin) floors)
(=/= 'adam f5)
(=/= 'bill f1)
(=/= 'cora f1) (=/= 'cora f5)
(highero 'dale 'bill floors)
(not-nexto 'erin 'cora floors)
(not-nexto 'cora 'bill floors)))

I also found there’s a queenso implementation in cKanren as well, but it seems commented out and not working :(

https://github.com/calvis/cKanren/blob/master/cKanren/tests/fd.rkt#L56

- scott

[Ryan Davis]

> On Jul 19, 2015, at 14:15, Scott Windsor <swin...@gmail.com> wrote:
>
> very cool.
>
> I moved to using cKanren to get =/= and was able to come up with a cleaner apartmento.
>
> (define (aparmento floors)
> (fresh (f1 f2 f3 f4 f5)
> (== floors (list f1 f2 f3 f4 f5))
> (memberso '(adam bill cora dale erin) floors)
> (=/= 'adam f5)
> (=/= 'bill f1)
> (=/= 'cora f1) (=/= 'cora f5)
> (highero 'dale 'bill floors)
> (not-nexto 'erin 'cora floors)
> (not-nexto 'cora 'bill floors)))

Apparently Dan Friedman thinks that the "o" suffix is "kind of like a question mark" (according to Byrd). I have NO idea why. Why not just take advantage of scheme and use a questionmark (or two, so null?? is the logic one)... or ¿null?

(¿members? '(adam bill cora dale erin) floors)
(¿higher? 'dale 'bill floors)
(¿not-next? 'erin 'cora floors)
(¿not-next? 'bill 'cora floors)

I love it.

[Ryan Davis]

> On Jul 19, 2015, at 14:15, Scott Windsor <swin...@gmail.com> wrote:
>

My permute version of queens is mega-fast compared to my previous mk version. 1.7 seconds for queens 8:

#lang racket/base

;; queens 1 = 1 : cpu time: 4 real time: 4 gc time: 0
;; queens 2 = 0 : cpu time: 1 real time: 1 gc time: 0
;; queens 3 = 0 : cpu time: 0 real time: 0 gc time: 0
;; queens 4 = 2 : cpu time: 0 real time: 0 gc time: 0
;; queens 5 = 10 : cpu time: 3 real time: 4 gc time: 0
;; queens 6 = 4 : cpu time: 18 real time: 18 gc time: 0
;; queens 7 = 40 : cpu time: 174 real time: 174 gc time: 4
;; queens 8 = 92 : cpu time: 1717 real time: 1716 gc time: 26
;; queens 9 = 352 : cpu time: 18773 real time: 18775 gc time: 232
;; queens 10 = 724 : cpu time: 229479 real time: 230187 gc time: 2865

(provide (all-defined-out))

(require "lib/reasonable.rkt")
(require "ch22.rkt")

(require (only-in racket/list range))

(define (safe b)
(define (no-diagonals° n m l)
(define (sub1° n m)
(cond-a [(null° n) (≈ n m)]
[(fresh (_)
(cons° m _ n))]))
(define (add1° n m)
(cons° n '() m))
(cond-a [(null° l) %s]
[else (fresh (a d n+1 n-1)
(sub1° n n-1)
(add1° m n+1)
(cons° a d l)
(cond-a [(≈ n+1 a) %u]
[(≈ n-1 a) %u]
[else (no-diagonals° n-1 n+1 d)]))]))
(cond-a [(null° b) %s]
[else (fresh (a d)
(cons° a d b)
(no-diagonals° a a d)
(safe d))]))

(define (permute l1 l2)
(define (do-insert x y out)
(cond-e [(cons° x y out)]
[(fresh (y1 y2 z)
(cons° y1 y2 y)
(cons° y1 z out)
(do-insert x y2 z))]))

(cond-e [(fresh (x)
(cons° x '() l1)
(cons° x '() l2))]
[(fresh (x y z1)
(cons° x y l1)
(cond-a [(≈ y '()) %u]
[else %s])
(permute y z1)
(do-insert x z1 l2))]))

;;; conversion utilities

(define (n->l n) ; number to list
(cond [(zero? n) '()]
[else (cons (n->l (sub1 n)) '())]))
(define (l->n l) ; list to number
(cond [(null? l) 0]
[else (add1 (l->n (car l)))]))
(define (ns->ls l) (map n->l l)) ; numbers to lists
(define (ls->ns l) (map l->n l)) ; lists to numbers
(define (lls->lns l) (map ls->ns l)) ; lists of lists to lists of numbers
(define (lns-lls l) (map ns->ls l)) ; lists of numbers to lists of lists

(define (queens n b)
(let ([rng (ns->ls (range 1 (add1 n)))])
(all
(permute rng b)
(safe b))))

(for ([n (range 1 13)])
(collect-garbage)
(time (printf "queens ~s = ~s : "
n
(length (run* (b) (queens n b))))))