home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / examples / calculator.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  8.9 KB  |  299 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         calculator.lsp
  5. ; RCS:          $Header: calculator.lsp,v 1.2 91/10/05 05:25:18 mayer Exp $
  6. ; Description:  A simple calculator -- note: the layout is pretty ugly.
  7. ;               Just load this file to get the application.
  8. ; Author:       Niels Mayer, HPLabs
  9. ; Created:      Wed Jun 27 23:39:09 1990
  10. ; Modified:     Sat Oct  5 05:24:44 1991 (Niels Mayer) mayer@hplnpm
  11. ; Language:     Lisp
  12. ; Package:      N/A
  13. ; Status:       X11r5 contrib tape release
  14. ;
  15. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  16. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  17. ;
  18. ; Permission to use, copy, modify, distribute, and sell this software and its
  19. ; documentation for any purpose is hereby granted without fee, provided that
  20. ; the above copyright notice appear in all copies and that both that
  21. ; copyright notice and this permission notice appear in supporting
  22. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  23. ; used in advertising or publicity pertaining to distribution of the software
  24. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  25. ; makes no representations about the suitability of this software for any
  26. ; purpose.  It is provided "as is" without express or implied warranty.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (setq top_w
  30.       (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "calc_shell"
  31.         :XMN_TITLE "WinterCalc"
  32.         :XMN_ICON_NAME "Calc"
  33.         ))
  34.  
  35. (setq paned_w
  36.     (send XM_PANED_WINDOW_WIDGET_CLASS :new :managed
  37.           "pane" top_w
  38.           ))
  39.  
  40.  
  41. ;==============================================================================
  42. ;============================== The display object=============================
  43. ;==============================================================================
  44.  
  45. ;; make a subclass of XM_TEXT_WIDGET_CLASS
  46. (setq *calc_display_class*
  47.       (send Class :new
  48.         '(cursor_pos
  49.           positive_p
  50.           ins_mode_p
  51.           begin_numentry_p
  52.           accumulator
  53.           prev_operator_symbol
  54.           )
  55.         '()                ;no class variables for subclass
  56.         XM_TEXT_WIDGET_CLASS)) 
  57.  
  58. ;; override XM_TEXT_WIDGET_CLASS's instance initializer
  59. (send *calc_display_class* :answer :isnew '(init-value &rest args)
  60.       '(
  61.     (setq cursor_pos 0)
  62.     (setq positive_p t)
  63.     (setq ins_mode_p t)
  64.     (setq begin_numentry_p nil)
  65.     (setq accumulator 0.0)
  66.     (setq prev_operator_symbol nil)
  67.     (apply 'send-super
  68.            `(:isnew ,@args
  69.             :XMN_STRING        ""
  70.             :XMN_EDIT_MODE        :single_line_edit
  71.             :XMN_AUTO_SHOW_CURSOR_POSITION t
  72.             :XMN_CURSOR_POSITION    ,cursor_pos
  73.             :XMN_EDITABLE        nil
  74. ;;;            :XMN_FOREGROUND        "Red"
  75. ;;;            :XMN_BACKGROUND        "Black"
  76.             ))
  77.     ))
  78.  
  79. (send *calc_display_class* :answer :enter_keystroke '(key_str)
  80.       '(
  81.     (cond
  82.      (begin_numentry_p
  83.       (send self :clear)
  84.       (setq begin_numentry_p nil)
  85.       )
  86.      )
  87.     (cond
  88.      (ins_mode_p
  89.       (send self :REPLACE cursor_pos cursor_pos key_str)
  90.       (setq cursor_pos (1+ cursor_pos))
  91.       (send self :SET_INSERTION_POSITION cursor_pos)
  92.       )
  93.      (t
  94.       (send self :REPLACE cursor_pos (1+ cursor_pos) key_str)
  95.       ))
  96.     )
  97.       )
  98.  
  99. (send *calc_display_class* :answer :change_sign '()
  100.       '(
  101.     (cond
  102.      (positive_p
  103.       (send self :REPLACE 0 0 "-")
  104.       (setq cursor_pos (1+ cursor_pos))
  105.       (send self :SET_INSERTION_POSITION cursor_pos)
  106.       (setq positive_p nil)
  107.       )
  108.      (t
  109.       (send self :REPLACE 0 1 "")
  110.       (setq cursor_pos (1- cursor_pos))
  111.       (send self :SET_INSERTION_POSITION cursor_pos)
  112.       (setq positive_p t)
  113.       )))
  114.       )
  115.  
  116. (send *calc_display_class* :answer :clear '()
  117.       '(
  118.     (setq cursor_pos 0)
  119.     (setq positive_p t)
  120.     (setq ins_mode_p t)
  121.     (send self :set_values
  122.           :XMN_STRING ""
  123.           :XMN_CURSOR_POSITION cursor_pos
  124.           )
  125.     ))
  126.  
  127. (send *calc_display_class* :answer :exec_unary_operator '(operator_symbol)
  128.       '(
  129.     (send self :set_accumulator_and_display 
  130.           (funcall operator_symbol (send self :get_display_as_flonum)))
  131.     (setq prev_operator_symbol nil)
  132.     ))
  133.  
  134. (send *calc_display_class* :answer :exec_binary_operator '(operator_symbol)
  135.       '(
  136.     (if prev_operator_symbol
  137.         (send self :set_accumulator_and_display 
  138.           (funcall prev_operator_symbol (send self :get_accumulator) (send self :get_display_as_flonum)))
  139.       (send self :set_accumulator_and_display (send self :get_display_as_flonum))
  140.       )
  141.     (setq prev_operator_symbol operator_symbol)
  142.     ))
  143.  
  144. ;; sets the accumulator to result_flonum, and displays that.
  145. ;; sets begin_numentry_p to true so that upon numentry, display is cleared and new number input.
  146. (send *calc_display_class* :answer :set_accumulator_and_display '(result_flonum)
  147.       '(
  148.     (setq accumulator result_flonum)
  149.     (setq cursor_pos 0)
  150.     (setq positive_p (not (minusp result_flonum)))
  151.     (setq ins_mode_p t)
  152.     (setq begin_numentry_p t)
  153.     (send self :set_values
  154.           :XMN_STRING (format NIL "~A" result_flonum)
  155.           :XMN_CURSOR_POSITION cursor_pos
  156.           )
  157.     ))
  158.  
  159. (send *calc_display_class* :answer :get_accumulator '()
  160.       '(
  161.     accumulator
  162.     ))
  163.  
  164.  
  165. (send *calc_display_class* :answer :get_display_as_flonum '()
  166.       '(
  167.     (float (read (make-string-input-stream (send self :get_string))))
  168.     ))
  169.  
  170. (setq *calc_display*
  171.       (send *calc_display_class* :new 0 :managed "disp" paned_w
  172.         ))
  173.  
  174. ;==============================================================================
  175. ;========================= The Numberpad ======================================
  176. ;==============================================================================
  177.  
  178. (defun make-number-button (parent_widget name)
  179.   (send
  180.    (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed name parent_widget
  181. ;;;      :XMN_FOREGROUND "Yellow"
  182. ;;;      :XMN_BACKGROUND "DimGrey"
  183.      )
  184.    :add_callback :xmn_activate_callback '()
  185.    `(
  186.      (send *calc_display* :enter_keystroke ,name)
  187.      )
  188.    ))
  189.  
  190. (defun make-chs-button (parent_widget name)
  191.   (send
  192.    (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed name parent_widget
  193. ;;;      :XMN_FOREGROUND "DimGrey"
  194. ;;;      :XMN_BACKGROUND "Yellow"
  195.      )
  196.    :add_callback :xmn_activate_callback '()
  197.    `(
  198.      (send *calc_display* :change_sign)
  199.      )
  200.    ))
  201.  
  202. (setq numpad_w
  203.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed "numbers" paned_w
  204.         :XMN_ORIENTATION        :vertical
  205.         :XMN_PACKING        :pack_column
  206.         :XMN_NUM_COLUMNS        3
  207.         :XMN_ADJUST_LAST         nil
  208.         :XMN_ENTRY_ALIGNMENT    :alignment_center
  209.         ))
  210.  
  211. (make-number-button numpad_w "7")
  212. (make-number-button numpad_w "4")
  213. (make-number-button numpad_w "1")
  214. (make-chs-button    numpad_w "+/-")
  215.  
  216. (make-number-button numpad_w "8")
  217. (make-number-button numpad_w "5")
  218. (make-number-button numpad_w "2")
  219. (make-number-button numpad_w "0")
  220.  
  221. (make-number-button numpad_w "9")
  222. (make-number-button numpad_w "6")
  223. (make-number-button numpad_w "3")
  224. (make-number-button numpad_w ".")
  225.  
  226. ;==============================================================================
  227. ;========================= Function Keys ======================================
  228. ;==============================================================================
  229.  
  230. (setq funcpad_w
  231.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed "functions" paned_w
  232.         :XMN_ORIENTATION        :vertical
  233.         :XMN_PACKING        :pack_column
  234.         :XMN_NUM_COLUMNS        3
  235.         :XMN_ADJUST_LAST         nil
  236.         :XMN_ENTRY_ALIGNMENT    :alignment_center
  237.         ))
  238.  
  239. (defun make-unary-operator (parent_widget operator_symbol name)
  240.   (send
  241.    (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed name parent_widget
  242. ;;;     :XMN_FOREGROUND "White"
  243. ;;;     :XMN_BACKGROUND "Blue"
  244.      )
  245.    :add_callback :xmn_activate_callback '()
  246.    `(
  247.      (send *calc_display* :exec_unary_operator operator_symbol)
  248.      )
  249.    ))
  250.  
  251. (defun make-binary-operator (parent_widget operator_symbol name)
  252.   (send (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed name parent_widget
  253. ;;;          :XMN_FOREGROUND "White"
  254. ;;;          :XMN_BACKGROUND "Blue"
  255.           )
  256.     :add_callback :xmn_activate_callback '()
  257.     `(
  258.       (send *calc_display* :exec_binary_operator operator_symbol)
  259.       )
  260.     ))
  261.  
  262. (make-binary-operator funcpad_w #'/    "/")
  263. (make-binary-operator funcpad_w #'*    "*")
  264. (make-binary-operator funcpad_w #'-    "-")
  265. (make-binary-operator funcpad_w #'+    "+")
  266. (make-binary-operator funcpad_w #'expt "x^y")
  267. (make-binary-operator funcpad_w NIL    "=" ) ; NOTE: = is a special NO-OP
  268.  
  269. (make-unary-operator funcpad_w #'sin   "Sin")
  270. (make-unary-operator funcpad_w #'cos   "Cos")
  271. (make-unary-operator funcpad_w #'tan   "Tan")
  272. (make-unary-operator funcpad_w #'asin  "ArcSin")
  273. (make-unary-operator funcpad_w #'acos  "ArcCos")
  274. (make-unary-operator funcpad_w #'atan  "ArcTan")
  275. (make-unary-operator funcpad_w #'exp   "Exp")
  276. (make-unary-operator funcpad_w #'sqrt  "Sqrt")
  277.  
  278. (send 
  279.  (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed "Clear" funcpad_w
  280. ;;;    :XMN_FOREGROUND "White"
  281. ;;;    :XMN_BACKGROUND "Blue"
  282.        )
  283.  :add_callback :xmn_activate_callback '()
  284.  `(
  285.    (send *calc_display* :set_accumulator_and_display 0)
  286.    )
  287.  )
  288.  
  289. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  290. (send top_w :realize)
  291.  
  292. ;(let (height)
  293. ;  (send controlpanel_w :get_values :xmn_height 'height)
  294. ;  (send controlpanel_w :set_values
  295. ;    :xmn_maximum height
  296. ;    :xmn_minimum height
  297. ;    )
  298. ;  )
  299.