I have compiled S7 with these options:
S7OPT+=-UWITH_GMP
S7OPT+=-DWITH_SYSTEM_EXTRAS
S7OPT+=-DWITH_IMMUTABLE_UNQUOTE
S7OPT+=-DWITH_NUMBER_SEPARATOR
After discovering the bug below I pulled in the latest S7 sources
but that had no effect. Then I discovered this bug that I can
reproduce in a smaller piece of code:
(define V (subvector
(vector #t #f #f #f #t #f #f #f #t #t #f #f #f #t #t #f) ;
random
0 16 '(4 4)))
(define (good-to-shape O TILE)
(define RET ())
(define ORDER (vector-length (O 0)))
(do ((Y 0 (+ Y 1))) ((= Y ORDER))
(do ((X 0 (+ X 1))) ((= X ORDER))
(when (O X Y)
(display (list 'found X Y RET))(newline)
(set! RET (cons (list (+ X 0) (+ Y 0)
TILE) RET)))))
RET)
(define (bad-to-shape O TILE)
(define RET ())
(define ORDER (vector-length (O 0)))
(do ((Y 0 (+ Y 1))) ((= Y ORDER))
(do ((X 0 (+ X 1))) ((= X ORDER))
(when (O X Y)
(display (list 'found X Y RET))(newline)
(set! RET (cons (list X Y TILE)
RET))))) ;;;;;
RET)
(display (bad-to-shape V 'red))
(newline)
(display "--------\n")
(display (good-to-shape V 'red))
(newline)
Minus the "found" lines this prints:
((4 2 red) (4 1 red) (4 1 red) (4 0 red) (4 0 red) (4 0 red))
--------
((3 2 red) (3 1 red) (2 1 red) (2 0 red) (1 0 red) (0 0 red))
But before that, this implementation of Redelmeier algorithm, to
construct Tetris pieces, fails strangly if the functions are put
in a sublet:
;; This doesn't work:
;;
;; (display ((*omino* 'poly-fixed) 4 (lambda (P) (display P) (newline))))
;;
;; ;poly-fixed-2: not enough arguments: ((lambda (G ORDER UNTRIED P U COMPLETE)
...) poly-fixed)
;; ; 'poly-fixed
;; ; , line 0, position: 69
;; poly-fixed-2: 'poly-fixed
;; ((*omino* 'poly-fixed) 4 (lambda (P) (dis...
;;
;;
;; (provide 'omino.scm)
;; (unless (defined? '*omino*) (define *omino* (with-let (sublet (unlet))
;; (set! *libraries* (cons (cons "omino.scm" (curlet)) *libraries*))
;; Redelmeier algorithm from
https://louridas.github.io/rwa/assignments/polyominoes/
(define (range MIN MAX)
(let next ((N MIN))
(if (> N MAX)
()
(cons N (next (+ N 1))))))
(define (poly-graph-right ORDER)
(map (lambda (X) (cons X 0)) (range 0 (- ORDER 1))))
(define (poly-graph-top ORDER)
(define ORDER-1 (- ORDER 1))
(map (lambda (Y)
(map (lambda (X) (cons X Y))
(range (- 0 ORDER-1 (- Y)) (- ORDER-1 Y))))
(range 1 ORDER-1)))
(define (poly-graph ORDER)
(let next ((G (cons (poly-graph-right ORDER) (poly-graph-top ORDER))))
(if (null? G)
()
(append (car G) (next (cdr G))))))
(define (set-has? S E)
(if (hash-table? S)
(S E)
(let next ((L S))
(and (not (null? L))
(or (equal? (car L) E)
(next (cdr L)))))))
(define (poly-all-adjacent N)
(define UP (cons (car N) (+ (cdr N) 1)))
(define DOWN (cons (car N) (- (cdr N) 1)))
(define RIGHT (cons (+ (car N) 1) (cdr N)))
(define LEFT (cons (- (car N) 1) (cdr N)))
(list UP RIGHT DOWN LEFT))
(define (poly-adjacent G N)
(let next ((A (poly-all-adjacent N)))
(if (null? A)
()
(if (set-has? G (car A))
(cons (car A) (next (cdr A)))
(next (cdr A))))))
(define (poly-neighbours G P)
(let next ((P P))
(if (null? P)
()
(append (poly-adjacent G (car P)) (next (cdr P))))))
(define (poly-fixed ORDER COMPLETE)
(poly-fixed-1 (poly-graph ORDER) ORDER (list (cons 0 0)) () COMPLETE))
(define (poly-fixed-1 G ORDER UNTRIED P COMPLETE)
(define (try)
(if (null? UNTRIED)
()
(let ((U (car UNTRIED)))
(set! UNTRIED (cdr UNTRIED))
U)))
(let next ((U (try)))
(unless (null? U)
(poly-fixed-2 G ORDER UNTRIED P U COMPLETE)
(next (try)))))
(define (poly-fixed-2 G ORDER UNTRIED P U COMPLETE)
(define CURRENT (append P (list U)))
(if (= (length CURRENT) ORDER)
(COMPLETE CURRENT)
(let ((NBRS ()))
(for-each (lambda (V)
(when (and #t (not (set-has? UNTRIED V))
(not (set-has? CURRENT V))
(not (set-has? (poly-neighbours
G P) V)))
(set! NBRS (append NBRS (list V)))))
(poly-adjacent G U))
(define NEW (append UNTRIED NBRS))
(poly-fixed-1 G ORDER NEW CURRENT COMPLETE))))
;; ))) *omino*
Matthew
_______________________________________________
Cmdist mailing list
[email protected]
https://cm-mail.stanford.edu/mailman/listinfo/cmdist
