home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xaw / list < prev    next >
Encoding:
Text File  |  1991-09-26  |  2.0 KB  |  65 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; List widget demo (directory browser)
  4.  
  5. (require 'xwidgets)
  6. (load-widgets shell form label command list)
  7. (require 'unix 'unix.o)
  8. (require 'sort 'qsort)
  9.  
  10. (define top (application-initialize 'list))
  11. (set-values! top 'allow-shell-resize #t)
  12.  
  13. (define form (create-managed-widget (find-class 'form) top))
  14.  
  15. (define quit (create-managed-widget (find-class 'command) form))
  16. (set-values! quit 'label "quit")
  17. (add-callback quit 'callback (lambda x (exit)))
  18.  
  19. (define back (create-managed-widget (find-class 'command) form))
  20. (set-values! back 'label "back" 'from-horiz quit)
  21. (add-callback back 'callback (lambda x (goto "..")))
  22.  
  23. (define lab (create-managed-widget (find-class 'label) form))
  24. (set-values! lab 'border-width 0 'from-horiz back 'resizable #t)
  25.  
  26. ;; List widget is broken; ``list'' resource *must* be initialized:
  27. (define lst (create-managed-widget (find-class 'list) form 'list '()))
  28. (set-values! lst 'from-vert lab 'resizable #t 'vertical-list #t)
  29.  
  30. (add-callback lst 'callback
  31.   (lambda (w i)
  32.     (let ((stat (file-status (string-append where "/" (car i)))))
  33.       (set-values! lab 'label stat)
  34.       (if (eq? stat 'directory)
  35.       (goto (car i))))))
  36.  
  37. (define (goto dir)
  38.   (if (string=? dir "..")
  39.       (begin
  40.     (if (not (string=? where "/"))
  41.         (begin
  42.               (set! where
  43.             (substring where 0
  44.                    (do ((i (- (string-length where) 2) (1- i)))
  45.                    ((char=? (string-ref where i) #\/) i))))
  46.               (if (eqv? where "")
  47.               (set! where "/")))))
  48.       (if (not (or (string=? dir "/") (string=? where "/")))
  49.       (set! where (string-append where "/")))
  50.       (set! where (string-append where dir)))
  51.   (set-values! lab 'label where)
  52.   (define l '())
  53.   (for-each (lambda (d) (if (not (member d '("." "..")))
  54.                 (set! l (cons d l))))
  55.         (read-directory where))
  56.   (set-values! lst 'default-columns
  57.     (max 2 (ceiling (/ (length l) 40))))
  58.   (list-change! lst (sort l string<?) #t))
  59.  
  60. (define where "")
  61. (goto "/")
  62. (set-values! lab 'label "Select directory:")
  63. (realize-widget top)
  64. (context-main-loop (widget-context top))
  65.