((( [logo]Racket )))Need Help?
AboutDownloadDocumentationPLaneTCommunityLearning
Home > jphelps > guiml.plt >  package version 2.0
main.rkt
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml"><head><title>PLaneT Package Repository : Home &gt; jphelps &gt; guiml.plt &gt;  package version 1.1</title><meta content="Racket" name="generator" /><meta content="text/html; charset=utf-8" http-equiv="Content-Type" /><link href="/plticon.ico" rel="icon" type="image/ico" /><link href="/plticon.ico" rel="shortcut icon" /><link href="/plt.css" rel="stylesheet" title="default" type="text/css" /><link rel="stylesheet" href="/css/main.css" type="text/css" /><link rel="stylesheet" href="/css/planet-browser-styles.css" type="text/css" /><style type="text/css">import "/css/main.css"; import "/css/planet-browser-styles.css"; import "http://www.racket-lang.org/plt.css"; </style></head>
<body><div class="racketnav"><div class="navcontent"><table border="0" cellpadding="0" cellspacing="0" width="100%"><tr><td><span class="navtitle" style="font-size: 100px; vertical-align: middle;">(</span><span class="navtitle" style="font-size: 80px; vertical-align: middle;">(</span><span class="navtitle" style="font-size: 60px; vertical-align: middle;">(</span><span class="navtitle" style="font-size: 40px; vertical-align: middle;">&nbsp;</span><img alt="[logo]" src="/logo.png" style="vertical-align: middle; margin: 13px 0.25em 0 0; border: 0;" /><span class="navtitle" style="font-size: 80px; vertical-align: middle;">Racket</span><span class="navtitle" style="font-size: 40px; vertical-align: middle;">&nbsp;</span><span class="navtitle" style="font-size: 60px; vertical-align: middle;">)</span><span class="navtitle" style="font-size: 80px; vertical-align: middle;">)</span><span class="navtitle" style="font-size: 100px; vertical-align: middle;">)</span></td><td class="helpiconcell"><span class="helpicon"><a href="http://racket-lang.org/help.html">Need Help?</a></span></td></tr><tr><td colspan="2"><table width="100%"><tr><td class="navlinkcell"><span class="navitem"><span class="navlink"><a href="http://racket-lang.org/">About</a></span></span></td><td class="navlinkcell"><span class="navitem"><span class="navlink"><a href="http://racket-lang.org/download/">Download</a></span></span></td><td class="navlinkcell"><span class="navitem"><span class="navlink"><a href="http://docs.racket-lang.org/">Documentation</a></span></span></td><td class="navlinkcell"><span class="navitem"><span class="navcurlink"><a href="/">PLaneT</a></span></span></td><td class="navlinkcell"><span class="navitem"><span class="navlink"><a href="http://racket-lang.org/community.html">Community</a></span></span></td><td class="navlinkcell"><span class="navitem"><span class="navlink"><a href="http://racket-lang.org/learning.html">Learning</a></span></span></td></tr></table></td></tr></table></div></div><div class="bodycontent"><div class="planet"><div class="filledinwhite"><div class="planetNav"><a href="/display.ss?">Home</a>&nbsp;&gt;&nbsp;<a href="/display.ss?owner=jphelps">jphelps</a>&nbsp;&gt;&nbsp;<a href="/display.ss?package=guiml.plt&amp;owner=jphelps">guiml.plt</a>&nbsp;&gt;&nbsp;<a href="/package-source/jphelps/guiml.plt/1/1/"> package version 1.1</a></div></div></div><div class="planet"><section>guiml.scm</section><div class="scheme"><pre><span class="selfeval">#lang</span> <span class="variable">scheme/gui</span>

(<span class="keyword">require</span> <span class="variable">mzlib/match</span>)

(<span class="keyword">define-struct</span> <span class="variable">widget</span>
  (<span class="variable">object</span> <span class="variable">id</span> <span class="variable">semaphore</span>))
(<span class="keyword">provide</span> <span class="variable">widget</span> <span class="variable">widget-object</span> <span class="variable">widget-id</span> <span class="variable">widget-semaphore</span>)


(<span class="keyword">define-syntax</span> <span class="variable">guiml-child</span>
  (<span class="keyword">syntax-rules</span> (<span class="variable">@</span>)
    ((<span class="variable">_</span> (<span class="variable">parent-binding</span>)) <span class="builtin">null</span>)
    
    ((<span class="variable">_</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> <span class="variable">id</span> (<span class="variable">@</span> . <span class="variable">properties</span>) . <span class="variable">tl</span>) . <span class="variable">siblings</span>))
     (<span class="builtin">cons</span>
      (<span class="variable">guiml</span> (<span class="variable">head</span> <span class="variable">id</span> (<span class="variable">@</span> (<span class="variable">parent</span> <span class="variable">parent-binding</span>) . <span class="variable">properties</span>)
                   . <span class="variable">tl</span>))
      (<span class="variable">guiml-child</span> (<span class="variable">parent-binding</span> . <span class="variable">siblings</span>))))
    
    ((<span class="variable">_</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> (<span class="variable">@</span> . <span class="variable">properties</span>) . <span class="variable">tl</span>) . <span class="variable">siblings</span>))
     (<span class="builtin">cons</span>
      (<span class="variable">guiml</span> (<span class="variable">head</span> (<span class="variable">@</span> (<span class="variable">parent</span> <span class="variable">parent-binding</span>) . <span class="variable">properties</span>) . <span class="variable">tl</span>))
      (<span class="variable">guiml-child</span> (<span class="variable">parent-binding</span> . <span class="variable">siblings</span>))))
    ((<span class="variable">_</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> <span class="variable">id</span> . <span class="variable">tl</span>) . <span class="variable">siblings</span>))
     (<span class="variable">guiml-child</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> <span class="variable">id</span> (<span class="variable">@</span>) . <span class="variable">tl</span>) . <span class="variable">siblings</span>)))
    ((<span class="variable">_</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> . <span class="variable">tl</span>) . <span class="variable">siblings</span>))
     (<span class="variable">guiml-child</span> (<span class="variable">parent-binding</span> (<span class="variable">head</span> (<span class="variable">@</span>) . <span class="variable">tl</span>) . <span class="variable">siblings</span>)))))

(<span class="keyword">define-syntax</span> <span class="variable">guiml</span>
  (<span class="keyword">syntax-rules</span> (<span class="variable">@</span>)
    ((<span class="variable">_</span> (<span class="variable">name</span> <span class="variable">id</span> (<span class="variable">@</span> . <span class="variable">properties</span>)))
     (<span class="variable">make-widget</span> (<span class="variable">new</span> <span class="variable">name</span> . <span class="variable">properties</span>) <span class="variable">id</span> (<span class="builtin">make-semaphore</span> <span class="selfeval">1</span>)))
    
    ((<span class="variable">_</span> (<span class="variable">name</span> <span class="variable">id</span> (<span class="variable">@</span> . <span class="variable">properties</span>) <span class="variable">first-child</span> . <span class="variable">rest-children</span>))
     (<span class="keyword">let</span> ((<span class="variable">top</span> (<span class="variable">new</span> <span class="variable">name</span> . <span class="variable">properties</span>)))
       (<span class="builtin">cons</span> (<span class="variable">make-widget</span> <span class="variable">top</span> <span class="variable">id</span> (<span class="builtin">make-semaphore</span> <span class="selfeval">1</span>))
             (<span class="variable">guiml-child</span> (<span class="variable">top</span> <span class="variable">first-child</span> . <span class="variable">rest-children</span>)))))
    
    <span class="comment">;; The ID field is optional and defaults to #f.
</span>    ((<span class="variable">_</span> (<span class="variable">name</span> (<span class="variable">@</span> . <span class="variable">properties</span>)))
     (<span class="variable">guiml</span> (<span class="variable">name</span> <span class="selfeval">#f</span> (<span class="variable">@</span> . <span class="variable">properties</span>))))
    
    <span class="comment">;; The properties field is optional for a widget that
</span>    <span class="comment">;; has no children, if an ID is specified.
</span>    
    ((<span class="variable">_</span> (<span class="variable">name</span> <span class="variable">id</span>)) (<span class="variable">make-widget</span> (<span class="variable">new</span> <span class="variable">name</span>) <span class="variable">id</span> (<span class="builtin">make-semaphore</span> <span class="selfeval">1</span>)))
    
    ((<span class="variable">_</span> (<span class="variable">name</span> . <span class="variable">rest</span>))
     (<span class="variable">guiml</span> (<span class="variable">name</span> <span class="selfeval">#f</span> . <span class="variable">rest</span>)))))

(<span class="keyword">define-syntax</span> <span class="variable">sendmsg</span>
  (<span class="keyword">syntax-rules</span> ()
    ((<span class="variable">_</span> <span class="variable">widget</span> <span class="variable">args</span> <span class="keyword">...</span>)
     (<span class="variable">send</span> (<span class="variable">widget-object</span> (<span class="keyword">if</span> (<span class="builtin">pair?</span> <span class="variable">widget</span>)
                              (<span class="builtin">car</span> <span class="variable">widget</span>) <span class="variable">widget</span>)) <span class="variable">args</span> <span class="keyword">...</span>))))
(<span class="keyword">provide</span> <span class="variable">sendmsg</span>)

(<span class="keyword">define</span> (<span class="variable">recursive-find</span> <span class="variable">pred</span> <span class="variable">list-data</span>)
  (<span class="variable">match</span> <span class="variable">list-data</span>
    (() <span class="selfeval">#f</span>)
    (((<span class="variable">?</span> <span class="variable">pred</span> <span class="variable">hd</span>) . <span class="variable">tl</span>) <span class="variable">hd</span>)
    (((<span class="variable">?</span> <span class="builtin">pair?</span> <span class="variable">hd</span>) . <span class="variable">tl</span>)
     (<span class="keyword">let</span> ((<span class="variable">verdict</span> (<span class="variable">recursive-find</span> <span class="variable">pred</span> <span class="variable">hd</span>)))
       (<span class="keyword">if</span> <span class="variable">verdict</span>
           <span class="variable">verdict</span>
           (<span class="variable">recursive-find</span> <span class="variable">pred</span> <span class="variable">tl</span>))))
    ((<span class="variable">_</span> . <span class="variable">tl</span>) (<span class="variable">recursive-find</span> <span class="variable">pred</span> <span class="variable">tl</span>))
    (<span class="variable">x</span> <span class="selfeval">#f</span>)))


(<span class="keyword">define</span> (<span class="variable">get-widget-by-id</span> <span class="variable">top-widget</span> <span class="variable">id</span> (<span class="variable">compare</span> <span class="builtin">eq?</span>))
  (<span class="variable">recursive-find</span>
   (<span class="keyword">lambda</span> (<span class="variable">widget</span>)
     (<span class="keyword">and</span> (<span class="variable">widget?</span> <span class="variable">widget</span>)
          (<span class="variable">compare</span> (<span class="variable">widget-id</span> <span class="variable">widget</span>) <span class="variable">id</span>)))
   <span class="variable">top-widget</span>))

(<span class="keyword">provide</span> <span class="variable">get-widget-by-id</span>)

<span class="comment">;;  (define (guiml form)
</span><span class="comment">;;   (construct-widget (guiml-internal form)))
</span>(<span class="keyword">provide</span> <span class="variable">guiml-child</span>)
(<span class="keyword">provide</span> <span class="variable">guiml</span>)</pre></div></div></div></body></html>