home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / examples / fake-app.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  8.6 KB  |  238 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         fake-app.lsp
  5. ; RCS:          $Header: fake-app.lsp,v 1.2 91/10/05 15:55:10 mayer Exp $
  6. ; Description:  Example application using XM_MAIN_WINDOW_WIDGET_CLASS +
  7. ;               XM_ROW_COLUMN_WIDGET_CLASS/:simple_menu_bar +
  8. ;               XM_ROW_COLUMN_WIDGET_CLASS/:simple_pulldown_menu
  9. ;        to create a window with a menubar and pulldowns, etc.
  10. ; Author:       Niels Mayer, HPLabs
  11. ; Created:      Fri Feb  8 19:59:47 1991
  12. ; Modified:     Sat Oct  5 15:52:34 1991 (Niels Mayer) mayer@hplnpm
  13. ; Language:     Lisp
  14. ; Package:      N/A
  15. ; Status:       X11r5 contrib tape release
  16. ;
  17. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  18. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  19. ;
  20. ; Permission to use, copy, modify, distribute, and sell this software and its
  21. ; documentation for any purpose is hereby granted without fee, provided that
  22. ; the above copyright notice appear in all copies and that both that
  23. ; copyright notice and this permission notice appear in supporting
  24. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  25. ; used in advertising or publicity pertaining to distribution of the software
  26. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  27. ; makes no representations about the suitability of this software for any
  28. ; purpose.  It is provided "as is" without express or implied warranty.
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (if (and (eq *MOTIF_VERSION* 1) (eq *MOTIF_REVISION* 0))
  32.     (error "Most features in fake-app.lsp are present only in Motif 1.1\
  33.             -- 1.0 doesn't have the required functions (yet)."))
  34.  
  35. (let (toplevel_w main_w menubar_w commandwindow_w edit_w)
  36.  
  37.   (setq toplevel_w
  38.     (send TOP_LEVEL_SHELL_WIDGET_CLASS :new 
  39.           :XMN_TITLE "Winterp: Fake Application"
  40.           :XMN_ICON_NAME "W:Fake-App"
  41.           ))
  42.  
  43.   (setq main_w
  44.     (send XM_MAIN_WINDOW_WIDGET_CLASS :new :managed
  45.           "mainw" toplevel_w
  46.           ))
  47.  
  48.   (setq menubar_w
  49.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed :simple_menu_bar
  50.           "menubar" main_w
  51.           :XMN_BUTTON_COUNT        5
  52.           :XMN_BUTTONS        #("Files" "Edit" "Fold" "Spindle" "Mutilate")
  53.           :XMN_BUTTON_MNEMONICS    #(#\F     #\E    #\o    #\S       #\M)
  54.           ))
  55.  
  56.   (send
  57.    (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  58.      "pulldown" menubar_w
  59.      :XMN_POST_FROM_BUTTON    0 ;post pulldown from menubar's "Files" button.
  60.      :XMN_BUTTON_COUNT    5 ;create five buttons in this pulldown
  61.      :XMN_BUTTONS        #("Quit" "Open" "Open in New Window" "Save" "Save As")
  62.      :XMN_BUTTON_MNEMONICS    #(#\Q    #\O    #\N                  #\S    #\A)
  63.      :XMN_BUTTON_MNEMONIC_CHAR_SETS    #("" "" "ISO8859-1" "ISO8859-1" "ISO8859-1")
  64.      :XMN_BUTTON_ACCELERATORS #("Ctrl<Key>C" "Ctrl<Key>F" "Ctrl<Key>O" "Ctrl<Key>S" "Ctrl<Key>W")
  65.      :XMN_BUTTON_ACCELERATOR_TEXT #("^C" "^F" "^O" "^S" "^W")
  66.      )
  67.    :add_callback :xmn_entry_callback    ;use this instead of XmNsimpleCallback
  68.    '(CALLBACK_ENTRY_WIDGET)
  69.    '(
  70.      ;; (send CALLBACK_ENTRY_WIDGET :name) returns "button_<#>"
  71.      ;; where <#> is 0 ... (button-count-1).
  72.      ;; we use 'read' to return the FIXNUM <#> after truncating the
  73.      ;; 7 chars "button_" from the front of the string.
  74.      (case (read (make-string-input-stream (send CALLBACK_ENTRY_WIDGET :name) 7))
  75.        (0 (format T "Quit Function Called\n"))
  76.        (1 (format T "Open Function Called\n"))
  77.        (2 (format T "Open in New Window Function Called\n"))
  78.        (3 (format T "Save Function Called\n"))
  79.        (4 (format T "Save As Function Called\n"))
  80.        (T (format T "Error\n")))
  81.      ))
  82.  
  83.   (setq edit_pd_w
  84.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  85.           "pulldown" menubar_w
  86.           :XMN_POST_FROM_BUTTON    1 ;post from menubar's "Edit"
  87.           :XMN_BUTTON_COUNT        8
  88.           :XMN_BUTTONS        #("One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight")
  89.           :XMN_BUTTON_MNEMONICS    #(#\O   #\T   #\h     #\F    #\i    #\S   #\e     #\g)
  90.           :XMN_BUTTON_TYPE        #(:PUSHBUTTON :TOGGLEBUTTON :CHECKBUTTON :RADIOBUTTON :CASCADEBUTTON :SEPARATOR :DOUBLE_SEPARATOR :TITLE)
  91.           ))
  92.   (send edit_pd_w :add_callback :xmn_entry_callback '(CALLBACK_ENTRY_WIDGET)
  93.     '(
  94.       (process-pulldown-buttonclick CALLBACK_ENTRY_WIDGET)
  95.       ))
  96.  
  97.   (send
  98.    (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  99.      "pulldown" edit_pd_w
  100.      :XMN_POST_FROM_BUTTON    4    
  101.      :XMN_BUTTON_COUNT    8
  102.      :XMN_BUTTONS        #("One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight")
  103.      :XMN_BUTTON_MNEMONICS    #(#\O   #\T   #\h     #\F    #\i    #\S   #\e     #\g)
  104.      :XMN_BUTTON_TYPE    #(:TITLE :DOUBLE_SEPARATOR :SEPARATOR :CASCADEBUTTON :RADIOBUTTON :CHECKBUTTON :TOGGLEBUTTON :PUSHBUTTON)
  105.      )
  106.    :add_callback :xmn_entry_callback '(CALLBACK_ENTRY_WIDGET)
  107.    '(
  108.      (process-pulldown-buttonclick CALLBACK_ENTRY_WIDGET)
  109.      ))
  110.  
  111.  
  112.   (send
  113.    (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  114.      "pulldown" menubar_w
  115.      :XMN_POST_FROM_BUTTON    2    ;post from menubar's "Fold"
  116.      :XMN_BUTTON_COUNT    5
  117.      :XMN_BUTTONS        #("One" "Two" "Three" "Four" "Five")
  118.      :XMN_BUTTON_MNEMONICS    #(#\O   #\T   #\h     #\F    #\i   )
  119.      )
  120.    :add_callback :xmn_entry_callback '(CALLBACK_ENTRY_WIDGET)
  121.    '(
  122.      (process-pulldown-buttonclick CALLBACK_ENTRY_WIDGET)
  123.      ))
  124.  
  125.   (send
  126.    (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  127.      "pulldown" menubar_w
  128.      :XMN_POST_FROM_BUTTON    3    ;post from menubar's "Spindle"
  129.      :XMN_BUTTON_COUNT    5
  130.      :XMN_BUTTONS        #("One" "Two" "Three" "Four" "Five")
  131.      :XMN_BUTTON_MNEMONICS    #(#\O   #\T   #\h     #\F    #\i   )
  132.      )
  133.    :add_callback :xmn_entry_callback '(CALLBACK_ENTRY_WIDGET)
  134.    '(
  135.      (process-pulldown-buttonclick CALLBACK_ENTRY_WIDGET)
  136.      ))
  137.  
  138.   (send
  139.    (send XM_ROW_COLUMN_WIDGET_CLASS :new :simple_pulldown_menu
  140.      "pulldown" menubar_w
  141.      :XMN_POST_FROM_BUTTON    4    ;post from menubar's "Mutilate"
  142.      :XMN_BUTTON_COUNT    5
  143.      :XMN_BUTTONS        #("One" "Two" "Three" "Four" "Five")
  144.      :XMN_BUTTON_MNEMONICS    #(#\O   #\T   #\h     #\F    #\i   )
  145.      )
  146.    :add_callback :xmn_entry_callback '(CALLBACK_ENTRY_WIDGET)
  147.    '(
  148.      (process-pulldown-buttonclick CALLBACK_ENTRY_WIDGET)
  149.      ))
  150.  
  151.   ;; NOTE: Motif 1.1 bug appears if we use :scrolled opt.
  152.   ;;      (strange interaction between scrolled list widget
  153.   ;;       and main_w manager)
  154.   ;;  (setq commandwindow_w
  155.   ;;    (send XM_LIST_WIDGET_CLASS :new :managed :scrolled
  156.   ;;          "commandwindow" main_w
  157.   ;;          :XMN_SELECTION_POLICY :extended_select
  158.   ;;          :XMN_LIST_SIZE_POLICY :constant
  159.   ;;          :XMN_SCROLL_BAR_DISPLAY_POLICY :static
  160.   ;;          :XMN_TRAVERSAL_ON T
  161.   ;;          :XMN_ITEMS list
  162.   ;;          :XMN_ITEM_COUNT length
  163.   ;;          :XMN_VISIBLE_ITEM_COUNT 10
  164.   ;;          ))
  165.  
  166.   (setq commandwindow_w
  167.     (send XM_FILE_SELECTION_BOX_WIDGET_CLASS :new :managed
  168.           "commandwindow" main_w
  169.           ))
  170.   (send (send commandwindow_w :get_child :DIALOG_HELP_BUTTON) :unmanage)
  171.   (send (send commandwindow_w :get_child :DIALOG_CANCEL_BUTTON) :unmanage)
  172.   (send commandwindow_w :set_callback :XMN_OK_CALLBACK
  173.     '(callback_value)        ;returns selected file as XmString 
  174.     '(
  175.       (send edit_w :find_file
  176.         (xm_string_get_l_to_r callback_value) 0)
  177.       ))
  178.  
  179.   (setq edit_w
  180.     (send XM_TEXT_WIDGET_CLASS :new :managed :scrolled
  181.           "edit" main_w
  182.           :XMN_EDIT_MODE :MULTI_LINE_EDIT
  183.           ))
  184.  
  185.   (send main_w :set_areas
  186.     menubar_w            ;set XmNmenuBar
  187.     commandwindow_w            ;set XmNcommandWindow
  188.     NIL                ;don't want a XmNhorizontalScrollBar
  189.     NIL                ;dont' want a XmNverticalScrollBar
  190.     (send edit_w :parent)        ;XmNworkWindow -- note, :parent retrieves scrolled-text's scrolled-window parent
  191.     )
  192.  
  193.   (send toplevel_w :realize)
  194.   )
  195.  
  196. (defun process-pulldown-buttonclick (w)
  197.   (format T "Process-pulldown-buttonclick(~A)\n" w)
  198.   (format T "\tName==~A Label==~A\n"
  199.       (send w :name)
  200.       (xm_string_get_l_to_r (car (send w :get_values :xmn_label_string nil))))
  201.   )
  202.  
  203.  
  204. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  205. ;; Add a :FIND_FILE method to the Motif Text widget.
  206. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  207. (send XM_TEXT_WIDGET_CLASS :answer :FIND_FILE '(filename linenum)
  208.       '(
  209.     (let*
  210.         (;; loc vars
  211.          (fp
  212.           (open filename :direction :input)
  213.           )
  214.          inspos
  215.          text_line
  216.          )
  217.  
  218.       (if (null fp)
  219.           (error "Can't open file." filename))
  220.  
  221.       (send self :set_string "")    ;clear out old text
  222.       (send self :disable_redisplay NIL) ;don't show changes till done
  223.       (loop
  224.        (if (null (setq text_line (read-line fp)))
  225.            (return))
  226.        (setq inspos (send self :get_insertion_position))
  227.        (send self :replace inspos inspos (strcat text_line "\n"))
  228.        )
  229.  
  230.       (send self :scroll linenum)    ;make <linenum> be the top of screen
  231.  
  232.       (send self :enable_redisplay)    ;now show changes...
  233.  
  234.       (close fp)
  235.       )
  236.     )
  237.       )
  238.