56 lines
2.0 KiB
Bash
Executable File
56 lines
2.0 KiB
Bash
Executable File
#!/bin/sh
|
|
:;exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;;;
|
|
;;;; s t k l o s - d e m o . s t k -- A demo which use some STklos classes
|
|
;;;;
|
|
;;;; Copyright © 1993-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: 24-Aug-1993 19:55
|
|
;;;; Last file update: 13-Sep-1999 18:03 (eg)
|
|
|
|
(require "Tk-classes")
|
|
|
|
;;;; Utilities
|
|
|
|
(define (make-rectangle coords tags)
|
|
(make <Rectangle> :parent c :coords coords :fill "Ivory4" :tags tags))
|
|
|
|
(define (make-circle coords tags)
|
|
(make <Oval> :parent c :coords coords :fill "Ivory4" :tags tags))
|
|
|
|
;;;; Make canvas
|
|
(define f (make <Frame>))
|
|
(define l (make <Label> :parent f :text "A simple demo written in STklos"))
|
|
(define c (make <Canvas> :parent f :relief "groove" :height 400 :width 700))
|
|
(define m (make <Label> :parent f :font '(Courier -12) :justify 'left
|
|
:foreground "red"
|
|
:text "Left button to move squares.
|
|
Right button to move circles"))
|
|
(define q (make <Button> :text "Quit" :command (lambda () (exit 0))))
|
|
|
|
(pack l c m q :in f :expand #t :fill 'both)
|
|
(pack f)
|
|
|
|
;;;; Make items
|
|
(define r1 (make-rectangle '(0 0 50 50) "Rect"))
|
|
(define r2 (make-rectangle '(100 100 150 150) "Rect"))
|
|
(define r3 (make-rectangle '(200 200 250 250) "Rect"))
|
|
|
|
(define c1 (make-circle '(50 50 100 100) "Circle"))
|
|
(define c2 (make-circle '(150 150 200 200) "Circle"))
|
|
(define c3 (make-circle '(250 250 300 300) "Circle"))
|
|
|
|
;;;; Make rectangles movable with button 1 and circles with button 2
|
|
(bind-for-dragging c :button 1 :tag "Rect")
|
|
(bind-for-dragging c :button 3 :tag "Circle")
|