Changeset 222
 Timestamp:
 08/18/11 12:21:39 (4 years ago)
 Location:
 trunk/lisp/lmwin
 Files:

 4 edited
Legend:
 Unmodified
 Added
 Removed

trunk/lisp/lmwin/menu.lisp
r221 r222 202 202 203 203 ;;; Mouseclick handler for menus. 204 ;;; The left button "selects". The meaning of this depends on the type of menu. 205 ;;; The middle button calls for documentation. 206 ;;; The right button is reserved. 204 ;;; All buttons are treated the same, select the item you are on. 207 205 ;;; There are no doubleclicks and you can't get to the system command menu. 208 206 ;;; Clicking when the menu is not exposed just exposes it. 209 207 210 208 (DEFMETHOD (BASICMENU :MOUSEBUTTONS) (BD X Y) 211 X Y ;ignored, we don't care where the mouse is, the :MOUSEMOVES method took care of that209 BD X Y ;ignored, we don't care where the mouse is, the :MOUSEMOVES method took care of that 212 210 (COND ((NOT EXPOSEDP) ;Button pushed while not exposed, expose self. 213 211 (FUNCALLSELF ':EXPOSE)) 214 ((BITTEST 2 BD) ;Middle button, get documentation215 (FUNCALLSELF ':DOCUMENT))216 212 ((NULL CURRENTITEM)) 217 (T ; Left or Rightbutton, select item.213 (T ;Any button, select item. 218 214 (SETQ LASTITEM CURRENTITEM 219 215 CHOSENITEM CURRENTITEM)))) … … 842 838 ;just complements highlight state. 843 839 (DEFMETHOD (MULTIPLEMENUMIXIN :MOUSEBUTTONS) (BD X Y &AUX ITEM) 844 X Y ;ignored, we don't care where the mouse is, the :MOUSEMOVES method took care of that840 BD X Y ;ignored, we don't care where the mouse is, the :MOUSEMOVES method took care of that 845 841 (COND ((NOT EXPOSEDP) ;Button pushed while not exposed, expose self. 846 842 (FUNCALLSELF ':EXPOSE)) 847 ((BITTEST 2 BD) ;Middle button, get documentation848 (FUNCALLSELF ':DOCUMENT))849 843 ((NULL (SETQ ITEM CURRENTITEM))) 850 844 ((AND (NOT (ATOM ITEM)) ;Specialchoice selected? 
trunk/lisp/lmwin/proces.lisp
r221 r222 91 91 STACKGROUP NIL 92 92 INITIALSTACKGROUP NIL)) 93 94 (DEFMETHOD (PROCESS :AFTER :INIT) (IGNORE) 95 (WITHOUTINTERRUPTS 96 (PROCESSALLPROCESSES SELF T))) 93 97 94 98 (DEFMETHOD (PROCESS :PRINTSELF) (STREAM &REST IGNORE) 
trunk/lisp/lmwin/stream.lisp
r221 r222 752 752 (+ (SHEETINSIDELEFT) PX4) (+ (SHEETINSIDETOP) PY4) 753 753 ALU SELF)))))))) 754 755 756 ;;; Cubic splines from Rogers and Adams, "Mathematical Elements 757 ;;; for Computer Graphics". This began as a translation from 758 ;;; a BASIC program, but has been changed a bit. The original 759 ;;; program uses a full matrix inversion when the boundary conditions 760 ;;; are cyclic or anticyclic, which is inefficient; in this version 761 ;;; the specialcase tridiagonal solver is extended to handle the 762 ;;; cyclic and anticyclic end conditions. (Also, the original program 763 ;;; has a bug wherein it neglects to initialize one diagonal of the M matrix.) 764 765 ;;; The caller has a sequence of points, in PX and PY, through which he 766 ;;; wants a smooth curve drawn. This program generates Z intermediate 767 ;;; points between each pair of points, returning a sequence of points 768 ;;; in CX and CY that includes the original points with the intermediate 769 ;;; points inserted. The caller can then plot lines between successive 770 ;;; pairs of points of CX and CY to draw the curve. 771 772 ;;; The caller may pass in arrays to be filled in with the answers (used as 773 ;;; CX and CY); they should be (+ N (* Z ( N 1))) long. If NIL is passed, 774 ;;; this function creates the arrays itself. If they are not long enough, 775 ;;; they are adjusted with ADJUSTARRAYSIZE. The optional argument C1 is 776 ;;; the initial end condition, one of :RELAXED, :CLAMPED, :CYCLIC, or 777 ;;; :ANTICYCLIC; C2 is the final end condition, one of :RELAXED or 778 ;;; :CLAMPED. The first defaults to :RELAXED, and the second defaults 779 ;;; to the first. The second must be the same as the first if the 780 ;;; first is :CYCLIC or :ANTICYCLIC. The last four arguments are 781 ;;; the X and Y values to which the endpoints are being clamped if 782 ;;; the corresponding boundary condition is :CLAMPED. For cyclic splines 783 ;;; that join themselves, the caller must pass the same point twice, as 784 ;;; both the first point and the last point. 785 786 ;;; Three values are returned: The two arrays CX and CY, and the number 787 ;;; of elements in the original P array. 788 789 (DEFUN SPLINE (PX PY Z &OPTIONAL CX CY (C1 ':RELAXED) (C2 C1) 790 P1PRIMEX P1PRIMEY PNPRIMEX PNPRIMEY 791 &AUX N N1 N2 N3 BX BY L UX UY N1 N2 N3 N4 SIGN 792 (ZUNDERFLOW T)) 793 (SETQ N (ARRAYACTIVELENGTH PX) ;The number of points 794 N1 (1 N) 795 N2 (1 N1) 796 N3 (1 N2)) 797 798 ;; Create the arrays if they were not given them, or redimension them if needed. 799 (LET ((CLEN (+ N (* N1 Z)))) 800 (COND ((NULL CX) 801 (SETQ CX (MAKEARRAY NIL 'ARTQ CLEN))) 802 ((< (ARRAYLENGTH CX) CLEN) 803 (SETQ CX (ADJUSTARRAYSIZE CX CLEN)))) 804 (COND ((NULL CY) 805 (SETQ CY (MAKEARRAY NIL 'ARTQ CLEN))) 806 ((< (ARRAYLENGTH CY) CLEN) 807 (SETQ CY (ADJUSTARRAYSIZE CY CLEN))))) 808 809 ;; Set up L to hold the approximate spline segment lengths. 810 ;; The Nth element of L holds the distance between the Nth and N+1st 811 ;; points of PX,PY. The last element of L is not used. 812 (SETQ L (MAKEARRAY NIL 'ARTQ N)) 813 (LOOP FOR J FROM 0 TO N2 814 DO (ASET (SMALLFLOAT (SQRT (+ (^ ( (AREF PX (1+ J)) (AREF PX J)) 2) 815 (^ ( (AREF PY (1+ J)) (AREF PY J)) 2)))) 816 L J)) 817 818 ;; The bulk of the code here is concerned with solving a set of 819 ;; simultaneous linear equations, expressed by the matrix equation 820 ;; M * U = B. M is an N by N square matrix, and B and U are N by 1 821 ;; column matricies. U will hold the values of the slope of the curve 822 ;; at each point PX, PY. 823 824 ;; The M matrix is tridiagonal for :RELAXED and :CLAMPED end conditions. 825 ;; We represent it by storing M(I,I1) in N1(I), M(I,I) in N2(I), and 826 ;; M(I,I+1) in N3(I). This means N1(0) and N3(N1) are unused. 827 (SETQ N1 (MAKEARRAY NIL 'ARTQ N) 828 N2 (MAKEARRAY NIL 'ARTQ N) 829 N3 (MAKEARRAY NIL 'ARTQ N)) 830 831 ;; These quantities are meaningless, but they get referred to as part 832 ;; of array bound conditions; these values just prevent errors from happening. 833 (ASET 0.0s0 N1 0) 834 (ASET 0.0s0 N3 N1) 835 836 (COND ((MEMQ C1 '(:CYCLIC :ANTICYCLIC)) 837 ;; With these conditions, the M matrix is not quite tridiagonal; 838 ;; it is initialize with a 1 in the upperright hand corner, and 839 ;; during the solution of the equations the whole right column 840 ;; gets nonzero values. Also, it is only N1 by N1! So the upper 841 ;; right corner is M(0, N2). N4 represents the N2 column; element 842 ;; M(I,N2) is stored in N4(I). The last two elements are not 843 ;; used, because N4(N2) = N2(N2) and N4(N3) = N3(N3). We also 844 ;; set up this handy SIGN variable. 845 (SETQ N4 (MAKEARRAY NIL 'ARTQ (1 N))) 846 (SETQ SIGN (IF (EQ C1 ':CYCLIC) 1.0s0 1.0s0))) 847 ((NOT (MEMQ C1 '(:RELAXED :CLAMPED))) 848 (FERROR NIL "~S is not known spline type" C1))) 849 ;; B is just a column vector, represented normally. 850 (SETQ BX (MAKEARRAY NIL 'ARTQ N) 851 BY (MAKEARRAY NIL 'ARTQ N)) 852 853 ;; Set up the boundary conditions. 854 ;; The 0th row of M and B are determined by the initial boundary conditions, 855 ;; and the N1st row is determined by the final boundary condition. 856 ;; Note that the 0th row of M is implemented as the 0th element of N2, N3, 857 ;; and sometimes N4; N1(0) is not used. A similar thing is true of the 858 ;; N1st row. 859 (SELECTQ C1 860 (:CLAMPED 861 (ASET 1.0s0 N2 0) 862 (ASET 0.0s0 N3 0) 863 (ASET P1PRIMEX BX 0) 864 (ASET P1PRIMEY BY 0)) 865 (:RELAXED 866 (ASET 1.0s0 N2 0) 867 (ASET 0.5s0 N3 0) 868 (LET ((TEM (// 3.0s0 (* 2.0s0 (AREF L 0))))) 869 (ASET (* TEM ( (AREF PX 1) (AREF PX 0))) BX 0) 870 (ASET (* TEM ( (AREF PY 1) (AREF PY 0))) BY 0))) 871 ((:CYCLIC :ANTICYCLIC) 872 (LET ((S3 (// (AREF L N2) (AREF L 0)))) 873 (ASET (+ 2.0s0 (* S3 2.0s0)) N2 0) 874 (ASET S3 N3 0) 875 (ASET SIGN N4 0) 876 (LET ((TEM (// 3.0s0 (AREF L 0)))) 877 (ASET (* TEM (+ (* S3 ( (AREF PX 1) (AREF PX 0))) 878 (* SIGN (// ( (AREF PX N1) (AREF PX N2)) S3)))) 879 BX 0) 880 (ASET (* TEM (+ (* S3 ( (AREF PY 1) (AREF PY 0))) 881 (* SIGN (// ( (AREF PY N1) (AREF PY N2)) S3)))) 882 BY 0))))) 883 (SELECTQ C2 884 (:CLAMPED 885 (ASET 0.0s0 N1 N1) 886 (ASET 1.0s0 N2 N1) 887 (ASET PNPRIMEX BX N1) 888 (ASET PNPRIMEY BY N1)) 889 (:RELAXED 890 (ASET 2.0s0 N1 N1) 891 (ASET 4.0s0 N2 N1) 892 (LET ((TEM (// 6.0s0 (AREF L N2)))) 893 (ASET (* TEM ( (AREF PX N1) (AREF PX N2))) BX N1) 894 (ASET (* TEM ( (AREF PY N1) (AREF PY N2))) BY N1))) 895 ;; Note: there are no final end conditions for :CYCLIC and :ANTICYCLIC, 896 ;; since they are the same at each end. The M matrix has no N1st row, 897 ;; either, as it is smaller by one row and one column. 898 ) 899 900 ;; Now fill in the insides of M and B arrays. 901 (LOOP FOR J FROM 1 TO N2 902 AS L0 := (AREF L 0) THEN L1 903 AS L1 := (AREF L 1) THEN (AREF L J) 904 AS PX0 := (AREF PX 0) THEN PX1 905 AS PX1 := (AREF PX 1) THEN PX2 906 AS PX2 := (AREF PX (1+ J)) 907 AS PY0 := (AREF PY 0) THEN PY1 908 AS PY1 := (AREF PY 1) THEN PY2 909 AS PY2 := (AREF PY (1+ J)) 910 DO (ASET L1 N1 J) 911 (ASET (* 2 (+ L0 L1)) N2 J) 912 (ASET L0 N3 J) 913 (IF N4 (ASET 0.0s0 N4 J)) 914 (ASET (// (* 3.0s0 (+ (* (^ L0 2) ( PX2 PX1)) (* (^ L1 2) ( PX1 PX0)))) 915 (* L0 L1)) BX J) 916 (ASET (// (* 3.0s0 (+ (* (^ L0 2) ( PY2 PY1)) (* (^ L1 2) ( PY1 PY0)))) 917 (* L0 L1)) BY J)) 918 919 ;; Now that we have the matricies filled in, we solve the equations. 920 ;; We use Gaussian elimination, with a special version that takes 921 ;; advantage of the sparsity of this tridiagonal or almosttridiagonal 922 ;; matrix to run in time O(n) instead of O(n**3). No pivoting is used, 923 ;; because for any real dat (not all zeroes, for example) the matrix 924 ;; is both irreducible and diagonallydominant, and therefore pivoting 925 ;; is not needed (Forsythe and Moler, p. 117, exercise 23.10). 926 ;; The first step is to make the matrix uppertriangular, by making all of 927 ;; N1 be zero. 928 (LET ((Q (AREF N2 0))) ;Normalize row 0. 929 (ASET (// (AREF N3 0) Q) N3 0) 930 (IF N4 (ASET (// (AREF N4 0) Q) N4 0)) 931 (ASET (// (AREF BX 0) Q) BX 0) 932 (ASET (// (AREF BY 0) Q) BY 0)) 933 (LOOP FOR I FROM 1 TO (IF (NULL N4) N1 N2) 934 AS N1I := (AREF N1 I) 935 WHEN (NOT (ZEROP N1I)) ;If it is zero already, OK. 936 DO (LET ((D (// 1.0s0 N1I))) 937 ;; D = M(I1, I1) / M(I, I1) so multiply row I 938 ;; by D and subtract row I1 from row I. 939 (ASET ( (* D (AREF N2 I)) (AREF N3 (1 I))) N2 I) 940 (ASET (* D (AREF N3 I)) N3 I) ; Uses N3(N1), a garbage element. 941 (COND (N4 942 (ASET ( (* D (AREF N4 I)) (AREF N4 (1 I))) N4 I) 943 (IF (= I N3) 944 ;; In this case, N4(N4) is above N3(N3), so 945 ;; it must be subtracted out. 946 (ASET ( (AREF N3 I) (AREF N4 (1 I))) N3 I)))) 947 (ASET ( (* D (AREF BX I)) (AREF BX (1 I))) BX I) 948 (ASET ( (* D (AREF BY I)) (AREF BY (1 I))) BY I) 949 ) 950 ;; Next normalize, by dividing row I through by M(I,I). 951 ;; This leaves the center diagonal all 1.0s0, which the 952 ;; backsolver in R&A doesn't take advantage of. 953 (LET ((Q (AREF N2 I))) 954 (ASET (// (AREF N3 I) Q) N3 I) 955 (IF N4 (ASET (// (AREF N4 I) Q) N4 I)) 956 (ASET (// (AREF BX I) Q) BX I) 957 (ASET (// (AREF BY I) Q) BY I))) 958 959 ;; Create the arrays to hold the answers. 960 (SETQ UX (MAKEARRAY NIL 'ARTQ N) ;Tangent vector matrix 961 UY (MAKEARRAY NIL 'ARTQ N)) 962 963 ;; Backsolve the uppertriangular matrix. 964 (COND ((NOT N4) 965 ;; Simpler version if there is no N4. 966 (ASET (AREF BX N1) UX N1) 967 (ASET (AREF BY N1) UY N1) 968 (LOOP FOR J FROM N2 DOWNTO 0 969 DO (LET ((N3J (AREF N3 J))) 970 (ASET ( (AREF BX J) (* N3J (AREF UX (1+ J)))) UX J) 971 (ASET ( (AREF BY J) (* N3J (AREF UY (1+ J)))) UY J)))) 972 (T 973 ;; Hairier version with N4. 974 (LET ((UXN2 (AREF BX N2)) 975 (UYN2 (AREF BY N2))) 976 (ASET UXN2 UX N2) 977 (ASET UYN2 UY N2) 978 (ASET ( (AREF BX N3) (* (AREF N3 N3) UXN2)) UX N3) 979 (ASET ( (AREF BY N3) (* (AREF N3 N3) UYN2)) UY N3) 980 (LOOP FOR J FROM (1 N3) DOWNTO 0 981 DO (LET ((N3J (AREF N3 J)) 982 (N4J (AREF N4 J))) 983 (ASET ( (AREF BX J) 984 (* N3J (AREF UX (1+ J))) 985 (* N4J UXN2)) 986 UX J) 987 (ASET ( (AREF BY J) 988 (* N3J (AREF UY (1+ J))) 989 (* N4J UYN2)) 990 UY J)))) 991 (ASET (* SIGN (AREF UX 0)) UX N1) 992 (ASET (* SIGN (AREF UY 0)) UY N1))) 993 994 (MULTIPLEVALUE (CX CY N) 995 (CURGEN N1 PX PY (1+ Z) CX CY L UX UY)) ;Generate it 996 997 (RETURNARRAY UY) 998 (RETURNARRAY UX) 999 (RETURNARRAY BY) 1000 (RETURNARRAY BX) 1001 (IF N4 (RETURNARRAY N4)) 1002 (RETURNARRAY N3) 1003 (RETURNARRAY N2) 1004 (RETURNARRAY N1) 1005 (RETURNARRAY L) 1006 1007 (PROG () (RETURN CX CY N))) 1008 1009 ;;; Generate the spline curve points. 1010 ;;; This is a separate function because if it got merged, there would 1011 ;;; be too many local variables. 1012 (DEFUN CURGEN (N1 PX PY Z CX CY L UX UY) 1013 (LOOP WITH I := 0 1014 FOR J FROM 0 TO (1 N1) 1015 AS FX1 := (AREF PX J) 1016 AND FX2 := (AREF UX J) 1017 AS TEMX := ( (AREF PX (1+ J)) FX1) 1018 AND TEMX1 := (+ (AREF UX (1+ J)) FX2) 1019 AND LEN := (AREF L J) 1020 AS LEN^2 := (^ LEN 2) 1021 AS LEN^3 := (* LEN^2 LEN) 1022 AS FX3 := ( (* (// 3.0s0 LEN^2) TEMX) (// (+ TEMX1 FX2) LEN)) 1023 AND FX4 := (+ (* (// 2.0s0 LEN^3) TEMX) (// TEMX1 LEN^2)) 1024 AS FY1 := (AREF PY J) 1025 AND FY2 := (AREF UY J) 1026 AS TEMY := ( (AREF PY (1+ J)) FY1) 1027 AND TEMY1 := (+ (AREF UY (1+ J)) FY2) 1028 AS FY3 := ( (* (// 3.0s0 LEN^2) TEMY) (// (+ TEMY1 FY2) LEN)) 1029 AND FY4 := (+ (* (// 2.0s0 LEN^3) TEMY) (// TEMY1 LEN^2)) 1030 DO (LOOP FOR X FROM 0 BY (// LEN Z) TO LEN 1031 WHEN (OR (= J 0) ( X 0)) 1032 DO (ASET (+ FX1 (* FX2 X) (* FX3 (^ X 2)) (* FX4 (^ X 3))) CX I) 1033 (ASET (+ FY1 (* FY2 X) (* FY3 (^ X 2)) (* FY4 (^ X 3))) CY I) 1034 (SETQ I (1+ I))) 1035 FINALLY (RETURN CX CY I))) 1036 1037 (DEFMETHOD (GRAPHICSMIXIN :DRAWCUBICSPLINE) 1038 (PX PY Z &OPTIONAL CURVEWIDTH ALU (C1 ':RELAXED) (C2 C1) 1039 P1PRIMEX P1PRIMEY PNPRIMEX PNPRIMEY) 1040 (IF (NULL ALU) 1041 (SETQ ALU CHARALUF)) 1042 (MULTIPLEVALUEBIND (CX CY I) 1043 (SPLINE PX PY Z NIL NIL C1 C2 P1PRIMEX P1PRIMEY PNPRIMEX PNPRIMEY) 1044 (IF (= CURVEWIDTH 1) 1045 (FUNCALLSELF ':DRAWCURVE CX CY I ALU) 1046 (FUNCALLSELF ':DRAWWIDECURVE CX CY CURVEWIDTH I ALU)))) 
trunk/lisp/lmwin/supdup.lisp
r221 r222 1062 1062 (FUNCALL STREAM ':TYO 377))))) ;IAC's must be quoted 1063 1063 1064 (DEFMETHOD (BASICTELNET :BUFFEREDTYO) (CH) 1065 (MULTIPLEVALUEBIND (IGNORE Y) (FUNCALLSELF ':READCURSORPOS) 1066 (COND ((= CH NVTIAC) 1067 (FUNCALLSELF ':HANDLEIAC)) ;Perform new telnet negotiations. 1068 (( 1064 (DEFMETHOD (BASICTELNET :BUFFEREDTYO) (CH &AUX CH1) 1065 (COND ((= CH NVTIAC) 1066 (FUNCALLSELF ':HANDLEIAC)) ;Perform new telnet negotiations. 1067 (( 1069 1068 CH 200)) ;Ignore otelnet negotiations 1070 1071 ((= CH 15)1072 (FUNCALLSELF ':FORCEOUTPUT)1073 (FUNCALLSELF ':SETCURSORPOS 0 Y))1074 ((= CH 12)1075 (FUNCALLSELF ':FORCEOUTPUT)1076 (FUNCALLSELF ':INCREMENTCURSORPOS 0 1 ':CHARACTER)1077 (FUNCALLSELF ':CLEAREOL))1078 1079 1080 1081 1069 ((= CH 7) (TV:BEEP)) ;^G rings the bell. 1070 ((AND (= CH 15) 1071 (IF (= (SETQ CH1 (NVTNETI)) 12) ;CR LF is NVT newline "character" 1072 NIL ;Output normally 1073 (FUNCALLSELF ':FORCEOUTPUT) 1074 (MULTIPLEVALUEBIND (IGNORE Y) (FUNCALLSELF ':READCURSORPOS) 1075 (FUNCALLSELF ':SETCURSORPOS 0 Y)) 1076 (ZEROP CH1)))) ;CR NUL is bare carriage return 1077 ((AND (= CH 177) SIMULATEIMLACFLAG) ;Escape character 1078 (FUNCALLSELF ':HANDLEIMLACESCAPE)) 1079 (T 1080 (AND ( 1082 1081 CH 10) ( 1083 1082 CH 15) ( CH 13) ;Convert formatting controls 1084 1085 1086 (FUNCALLSELF ':FORCEOUTPUT))))))1083 (SETQ CH (+ CH 200))) ;to Lisp machine char set. 1084 (DO () ((ARRAYPUSH OUTPUTBUFFER CH)) 1085 (FUNCALLSELF ':FORCEOUTPUT))))) 1087 1086 1088 1087 ;;;New telnet protocol IAC handler
Note: See TracChangeset
for help on using the changeset viewer.