Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
C
clim-tos
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Alastair Bridgewater
clim-tos
Commits
acf210dc
Commit
acf210dc
authored
32 years ago
by
cer
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
9c44d11f
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
clim/activities.lisp
+243
-0
243 additions, 0 deletions
clim/activities.lisp
demo/demo-activity.lisp
+76
-0
76 additions, 0 deletions
demo/demo-activity.lisp
with
319 additions
and
0 deletions
clim/activities.lisp
0 → 100644
+
243
−
0
View file @
acf210dc
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
(
in-package
:clim-internals
)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved.
Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved."
(
defclass
activity
()
((
frames
:initform
nil
:accessor
activity-frames
)
(
pretty-name
:accessor
activity-pretty-name
)
(
top-level-process
:initform
nil
)
(
active-frame
:initform
nil
:initarg
:initial-frame
:accessor
activity-active-frame
)
(
input-buffer
:initform
(
make-locking-queue
)
:accessor
activity-input-buffer
)
(
auto-select
:initform
nil
:initarg
:auto-select
:accessor
activity-auto-select
)
))
(
defmethod
initialize-instance
:after
((
activity
activity
)
&key
pretty-name
)
(
setf
(
activity-pretty-name
activity
)
(
or
pretty-name
(
title-capitalize
(
string
(
type-of
activity
))))))
(
defmethod
run-activity-top-level
:around
((
activity
activity
)
&key
&allow-other-keys
)
(
with-simple-restart
(
activity-exit
"Exit activity ~A"
(
activity-pretty-name
activity
))
(
loop
(
with-simple-restart
(
nil
"~A top level"
(
activity-pretty-name
activity
))
(
loop
#-
CCL-2
(
return-from
run-activity-top-level
(
call-next-method
))
#+
CCL-2
(
let
((
results
(
multiple-value-list
(
call-next-method
))))
(
return-from
run-activity-top-level
(
values-list
results
))))))))
(
defmethod
activity-exit
((
activity
activity
))
(
invoke-restart
'activity-exit
))
(
defmethod
run-activity-top-level
((
activity
activity
)
&key
&allow-other-keys
)
(
with-slots
(
top-level-process
)
activity
(
when
top-level-process
(
cerror
"Bludgeon ahead, assuming the risk"
"The process ~S is already running the top-level function for frame ~S"
top-level-process
activity
))
(
unwind-protect
(
progn
(
setq
top-level-process
(
current-process
))
(
default-activity-top-level
activity
))
(
setq
top-level-process
nil
))))
(
defvar
*activity*
nil
)
(
defmethod
default-activity-top-level
((
activity
activity
))
(
unless
(
activity-active-frame
activity
)
(
setf
(
activity-active-frame
activity
)
(
or
(
car
(
active-frames
activity
))
(
start-initial-application-frame
activity
))))
(
loop
(
let
((
*activity*
activity
)
(
*original-stream*
nil
)
(
*input-wait-test*
nil
)
(
*input-wait-handler*
nil
)
(
*pointer-button-press-handler*
nil
)
(
*numeric-argument*
nil
)
(
*delimiter-gestures*
nil
)
(
*activation-gestures*
nil
)
(
*accelerator-gestures*
nil
)
(
*accelerator-numeric-argument*
nil
)
(
*input-context*
nil
)
(
*accept-help*
nil
)
(
*assume-all-commands-enabled*
nil
)
(
*command-parser*
'command-line-command-parser
)
(
*command-unparser*
'command-line-command-unparser
)
(
*partial-command-parser*
'command-line-read-remaining-arguments-for-partial-command
)
;; Start these out nowhere
;;-- Surely these are bound by the frame top level
;; (*standard-output* nil)
;; (*standard-input* nil)
;; (*query-io* nil)
(
*pointer-documentation-output*
nil
))
(
loop
(
with-simple-restart
(
nil
"~A top level"
(
activity-pretty-name
activity
))
(
catch
'window-resynchronize
(
unless
(
activity-active-frame
activity
)
(
setf
(
activity-active-frame
activity
)
(
car
(
activity-frames
activity
))))
(
unless
(
activity-active-frame
activity
)
(
activity-exit
activity
))
(
let*
((
frame
(
activity-active-frame
activity
))
(
*application-frame*
frame
)
(
top-level
(
frame-top-level
frame
)))
(
unwind-protect
(
loop
(
catch
'layout-changed
(
with-frame-manager
((
frame-manager
frame
))
(
setf
(
slot-value
frame
'top-level-process
)
(
slot-value
activity
'top-level-process
))
(
if
(
atom
top-level
)
(
funcall
top-level
frame
)
(
apply
(
first
top-level
)
frame
(
rest
top-level
))))
(
break
"do something"
)))
(
setf
(
slot-value
frame
'top-level-process
)
nil
)))))))))
;;;---
(
defclass
activity-frame
(
standard-application-frame
)
((
activity
:initform
nil
:accessor
frame-activity
:initarg
:activity
)))
(
defgeneric
activity-quit
(
activity
)
(
:documentation
"Closes all frames and exits the top-level-loop"
)
(
:method
((
activity
activity
))
(
dolist
(
frame
(
frame-manager-frames
activity
))
(
close-application-frame
activity
frame
))))
(
defgeneric
start-initial-application-frame
(
activity
)
(
:documentation
"Starts the initial application, when the activity is startet up. ~
There is no default method, so subclasses MUST implement this."
))
(
defgeneric
start-application-frame
(
activity
&rest
frame-options
)
(
:documentation
"Starts an application frame and registers it in the activity. ~
The frame is exposed, so appropriate handlers will probably make it ~
the active frame. This function must be run inside a command to ~
synchronize the command loop."
))
(
defgeneric
close-application-frame
(
activity
frame
)
(
:documentation
"Closes the application-frame frame and de-registers it in the activity. ~
The frame is de-exposed, so appropriate handlers will probably make another ~
frame the active frame. This function must be run inside a command to ~
synchronize the command loop."
))
(
defmethod
start-application-frame
((
activity
activity
)
&rest
frame-options
)
(
let*
((
frame
(
apply
#'
make-application-frame
(
append
frame-options
(
list
:input-buffer
(
activity-input-buffer
activity
)
:activity
activity
)))))
(
enable-frame
frame
)
(
push
frame
(
activity-frames
activity
))
frame
))
(
defmethod
close-application-frame
((
activity
activity
)
(
frame
activity-frame
))
;; do we have to take care of the input-buffer that it will not be reused by
;; some magic resource mechanism?
(
disable-frame
frame
)
(
setf
(
activity-frames
activity
)
(
remove
frame
(
activity-frames
activity
)))
(
setf
(
frame-activity
frame
)
nil
)
(
when
(
eq
frame
(
activity-active-frame
activity
))
(
if
(
activity-frames
activity
)
(
setf
(
activity-active-frame
activity
)
nil
)
(
activity-exit
activity
))))
;;;
;;; callbacks from the window manager
;;;
(
defgeneric
activity-frame-window-select
(
activity-frame
)
(
:documentation
"This function is called when the window manager of the host's display server ~
selects the (a?) window of the frame activity-frame. Methods can specialize ~
on this callback to provide customized behavior -- e.g. dependent from the ~
state of the CP throw out of the command loop or not. (see example code). ~
The default method sets activity-frame as the active frame and throws to ~
the tag 'window-resynchronize to restart the command loop."
)
(
:method
((
frame
activity-frame
))
;;--- We should think about exporting the cp-state and so
;;--- give the the application more of a chance.
(
let
((
activity
(
frame-activity
frame
)))
(
when
(
and
(
frame-activity
frame
)
(
activity-auto-select
activity
)
*input-buffer-empty*
*reading-frame-command*
)
(
select-activity-active-frame
activity
frame
)))))
(
defun
select-activity-active-frame
(
activity
frame
)
;;-- Mark current frame in need of throwing
(
setf
(
activity-active-frame
activity
)
frame
)
(
throw
'window-resynchronize
:window-resynchronize
))
(
defmethod
activity-frame-window-select
:around
((
activity-frame
activity-frame
))
(
unless
(
eq
activity-frame
(
activity-active-frame
(
frame-activity
activity-frame
)))
(
call-next-method
)))
(
defmethod
receive-gesture
:after
((
stream
top-level-sheet
)
(
gesture
pointer-enter-event
))
(
unless
(
eq
(
pointer-boundary-event-kind
gesture
)
:inferior
)
(
let
((
frame
(
pane-frame
stream
)))
(
when
(
typep
frame
'activity-frame
)
(
activity-frame-window-select
frame
)))))
(
defgeneric
activity-frame-window-close
(
activity-frame
)
(
:documentation
"This function is called when the window manager of the host's display server ~
closes the (a?) window of the frame activity-frame. Methods can specialize ~
on this callback to provide customized behavior. ~
The default method calls close-application-frame on the frame's activity and ~
the frame as arguments."
)
(
:method
((
frame
activity-frame
))
(
when
(
frame-activity
frame
)
(
close-application-frame
(
frame-activity
frame
)
frame
)
;; we dont want throw out from here, dont we?
;;-- Mark current frame in need of throwing
;(throw 'window-resynchronize :window-resynchronize)
)))
(
defmethod
frame-exit
((
frame
activity-frame
))
(
activity-frame-window-close
frame
))
(
defmethod
redisplay-frame-panes
((
frame
activity-frame
)
&rest
options
)
;; First display all the :accept-values panes, then display the rest.
;; We do this to ensure that all side-effects from :accept-values panes
;; have taken place.
(
apply
#'
redisplay-activity-panes
(
frame-activity
frame
)
options
))
(
defmethod
redisplay-activity-panes
((
activity
activity
)
&key
force-p
)
(
dolist
(
frame
(
activity-frames
activity
))
(
map-over-sheets
#'
(
lambda
(
sheet
)
(
when
(
typep
sheet
'accept-values-pane
)
(
redisplay-frame-pane
frame
sheet
:force-p
force-p
)))
(
frame-top-level-sheet
frame
)))
(
dolist
(
frame
(
activity-frames
activity
))
(
map-over-sheets
#'
(
lambda
(
sheet
)
(
when
(
and
(
typep
sheet
'clim-stream-pane
)
(
not
(
typep
sheet
'accept-values-pane
)))
(
redisplay-frame-pane
frame
sheet
:force-p
force-p
)))
(
frame-top-level-sheet
frame
))))
(
defmethod
disable-frame
:after
((
frame
activity-frame
))
(
let
((
activity
(
frame-activity
frame
)))
(
when
(
and
activity
(
eq
(
activity-active-frame
frame
)
frame
))
(
setf
(
activity-active-frame
frame
)
nil
)
;;--- Need to resynchronize at this point
;;--- We should set flag in frame so that the default top level
;;--- notices this and exits or throws
)))
This diff is collapsed.
Click to expand it.
demo/demo-activity.lisp
0 → 100644
+
76
−
0
View file @
acf210dc
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: clim-demo; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
(
in-package
:clim-demo
)
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved.
Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved."
(
defclass
demo-activity
(
activity
)
nil
)
(
define-application-frame
demo-app
(
activity-frame
)
()
(
:panes
(
interactor
:interactor
)
(
display
:application
))
(
:pointer-documentation
t
)
(
:layouts
(
default
(
vertically
()
(
1/2
interactor
)
(
:fill
display
)))))
(
define-demo-app-command
(
com-activity-exit
:menu
t
:name
"Exit"
)
()
(
activity-frame-window-close
*application-frame*
))
(
defvar
*untitled-count*
1
"Counter for naming new, untitled document windows"
)
;;; This method must be implemented by subclasses of activity
(
defmethod
start-initial-application-frame
((
activity
demo-activity
))
(
start-application-frame
activity
'demo-app
:width
200
:height
200
:pretty-name
"Initial"
))
(
define-demo-app-command
(
com-new
:menu
t
:name
t
)
((
name
'string
:prompt
"Name of Window"
:default
(
format
nil
"Untitled-~A"
*untitled-count*
)
:display-default
t
:documentation
"A Title String"
))
(
start-application-frame
(
frame-activity
*application-frame*
)
'demo-app
:width
200
:height
200
:pretty-name
name
)
(
incf
*untitled-count*
))
(
define-demo-app-command
(
com-select-frame
:name
t
:menu
t
)
((
frame
`
((
member
,@
(
activity-frames
*activity*
))
:name-key
,
#'
frame-pretty-name
)))
(
select-activity-active-frame
*activity*
frame
))
(
define-demo-app-command
(
com-funky-add
:name
t
:menu
t
)
((
n
'number
))
(
flet
((
print-random-sum
(
stream
n
)
(
let
((
sum
(
+
n
(
random
20
)
-10
)))
(
with-output-as-presentation
(
stream
sum
'number
)
(
format
stream
"~%~A plus ~A gives ~A"
n
(
-
sum
n
)
sum
)))))
(
print-random-sum
(
get-frame-pane
*application-frame*
'display
)
n
)))
;; This one gives a nicer pointer doc than the default one by the
;; :gesture option of define-command
(
define-presentation-to-command-translator
add-number
(
number
com-funky-add
demo-app
:pointer-documentation
((
stream
object
)
(
format
stream
"Add something to ~A"
object
)))
(
object
)
`
(
,
object
))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment