67 lines
2.2 KiB
Plaintext
67 lines
2.2 KiB
Plaintext
;;;; puzzle.stk -- A puzzle written in STk (from the Tcl Demo)
|
|
;;;;
|
|
;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;;
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 9-Mar-1998 21:11
|
|
;;;;Last file update: 3-Sep-1999 18:50 (eg)
|
|
|
|
(define (display-puzzle parent)
|
|
|
|
(define (puzzle-switch w num xpos ypos space)
|
|
(let ((x (vector-ref xpos num))
|
|
(y (vector-ref ypos num))
|
|
(x_spc (vector-ref xpos space))
|
|
(y_spc (vector-ref ypos space)))
|
|
(when (or (and (>= y (- y_spc 0.01)) (<= y (+ y_spc 0.01))
|
|
(>= x (- x_spc 0.26)) (<= x (+ x_spc 0.26)))
|
|
(and (>= x (- x_spc 0.01)) (<= x (+ x_spc 0.01))
|
|
(>= y (- y_spc 0.26)) (<= y (+ y_spc 0.26))))
|
|
(vector-set! xpos space x)
|
|
(vector-set! xpos num x_spc)
|
|
(vector-set! ypos space y)
|
|
(vector-set! ypos num y_spc)
|
|
(place w :relx x_spc :rely y_spc))))
|
|
|
|
(let ((order '#(3 1 6 2 5 7 15 13 4 11 8 9 14 10 12))
|
|
(xpos (make-vector 16))
|
|
(ypos (make-vector 16))
|
|
(space 0)
|
|
(f (frame (format #f "~A.f" (widget-name parent))
|
|
:width 150 :height 150 :bd 4 :relief "solid")))
|
|
|
|
(do ((i 0 (+ i 1)))
|
|
((= i 15))
|
|
(let* ((num (vector-ref order i))
|
|
(b (button (format #f "~A.b~A" (widget-name f) i) :text num
|
|
:highlightthickness 0)))
|
|
;; Set the command of the button (and grab current environment)
|
|
(tk-set! b :command (lambda ()
|
|
(puzzle-switch b num xpos ypos space)))
|
|
|
|
(vector-set! xpos num (* (modulo i 4) 0.25))
|
|
(vector-set! ypos num (* (floor (/ i 4)) 0.25))
|
|
|
|
(place b :relx (vector-ref xpos num)
|
|
:rely (vector-ref ypos num)
|
|
:relwidth 0.25
|
|
:relheight 0.25)))
|
|
(vector-set! xpos space 0.75)
|
|
(vector-set! ypos space 0.75)
|
|
|
|
(pack f :expand #t :fill "both")
|
|
f))
|
|
|
|
|
|
|