/[cello]/cello/focus-navigation.lisp
ViewVC logotype

Contents of /cello/focus-navigation.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Jun 16 12:39:20 2008 UTC (5 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +1 -1 lines
nothing special
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 ;_____________________ N a v i g a t i o n ____________________
20 ;
21 (defun focus-navigate (old new &optional leave-old)
22 #+x42 (trc "focus-navigate > old, new" old new)
23 ;; (c-assert new) ;; 990810kt i don't remember if we navigate to nil (should tho) ///
24
25 (when (eql old new)
26 (return-from focus-navigate new))
27
28 (unless old
29 (focus-navi-enter new)
30 (focus-on new)
31 (return-from focus-navigate new))
32
33 (let ((resting
34 (catch :focus-navigate
35 (let (in-range)
36 (labels ((step-stone (stone)
37 ;;(trc "step-stone" stone in-range)
38 (when (eql stone new)
39 (when (and leave-old old)
40 (setf leave-old nil)
41 (focus-navi-leave old))
42 (when in-range ; if not in range, navving backwards
43 (focus-navi-enter stone))
44 (throw :focus-navigate new))
45 (when (kids stone)
46 (dolist (kid (kids stone))
47 (step-stone kid)))
48 (when (eql stone old)
49 (setf in-range t))
50 (when in-range
51 (setf leave-old nil)
52 (focus-navi-leave stone))))
53 ;
54 (step-stone (fm-ascendant-common old new))
55 ;; (step-stone (focus-navi-cares (fm-ascendant-common old new) old))
56 ;
57 )))))
58 #+nah (trc "focus-navigate > BINGO: root, old, new, newtracker"
59 (find-focus-root resting) old resting (focuser resting))
60 (with-metrics (nil nil "Actual set focus")
61 (focus-on resting))
62 ))
63
64 (defun focus-navi-cares (top-focus start-focus)
65 (cond ((eql top-focus start-focus) start-focus)
66 ((focus-cares top-focus) top-focus)
67 (t (focus-navi-cares (fm-kid-containing top-focus start-focus) start-focus))))
68
69 (defmethod focus-cares (wk)
70 (declare (ignore wk))
71 t)
72
73 (defmethod focus-navi-enter (work)
74 (declare (ignorable work))
75 #+navi (trc "focus-navi-enter >" work)
76 )
77
78 (defmethod focus-navi-leave (work)
79 (declare (ignore work)))
80

  ViewVC Help
Powered by ViewVC 1.1.5