- cl-cairo2-cvs@common-lisp.net - mailman3.common-lisp.net

[cl-cairo2-cvs] Is Israel a Democracy? -- The problem with intellectually insecure whites -- Should Christians Support Israeli Terrorism in Gaza?
by Lawrence Auster 23 Jan '09

23 Jan '09

The Jewish State of Israel has no constitution, nor does it name its borders. Israel's hidden constitution is Judaism. Israel's undeclared borders range from the Nile to the Euphrates rivers. Israel's desired jurisdiction extends over the entire Earth. It could not be more clear that the Jewish State follows a foreign policy which obeys Jewish Law as iterated in the Hebrew Bible, the Talmud, Maimonedes, the Cabalah, and the many commentaries and refinements of same. The Jews are genociding the native inhabitants of Palestine, just as their religion advises, and because their religion teaches them to do so. They treat non-Jews as if non-humans, just as their religion requires them to do. They make perpetual war on every nation on Earth, just as their genocidal Jewish God has instructed. The Jews of Israel are simply being Jews. Jews are an existential threat to the human race. Israel contains one third of the Jews of the World. It is not some aberration of the Jewish spirit, but the condensation and concentration of the perverse Jewish mentality, which malady also pervades the remaining two thirds of Jewry, who almost unanimously support the Jewish State, and who certainly do unanimously support the Jewish People and its consistent and constant crimes against the human race. Israel is Jewry and the danger of Israel is the danger of the Jewish People to all others, as the Jews have demonstrated each and every day of their existence. The Jews, the entire Jewish People of 15 million, will not relent until they have wiped out all non-Jews in "Greater Israel". They will not stop destroying all other cultures, nations, religions, ethnicities, races, competition, etc. until they are either stopped, or succeed in their ancient quest to destroy the human race. What Israel is doing is not some reaction to outside forces, nor was the formation of Israel a response to the Holocaust. Israel is simply following the plan laid out in the Jews' religious texts. The Jews have openly planned to take Palestine and genocide the native population of Palestine for some 2,500 years before the Holocaust. The Jews have openly complained that "anti-Semitism" is a threat that gives them the right to genocide the Palestinians, not merely since the advent of Nazism, but for some 2,500 years. The Jewish religion is the Constitution of the Jewish State of Israel, and, to a greater or lesser extent, the constitution of the nature of every Jew alive. The borders of Israel are the range the Jew roams over the entire World. The perverse Jewish mentality is inbred by a Jew's exposure to his parents and to his community. Judaism passes in the spit and slobber of Jewish mother telling her Jewish child that he is a "Jew", as much as Judaism passes in the poison and pain of a Talmudic tractate. The secular Jews did not suddenly come to life after the Enlightenment and the Jewish Reformation a body of vampires that appeared ex nihilo, in vacuo, mostly atheistical and undetached from formally practiced Judaism. Judaism is the Jew. It is a mindset that transcends and supercedes religion. It is a belief set, a way of life, a perception of one's self and one's relation to the World that makes a Jew, a Jew, and a danger to all of humanity. In fact, the religious shell of Judaism is like the stretched and infected skin of a lycanthropic pustule. When you lance it to cure the infection, the virus only becomes more contagious and spills directly on the non-Jew. The secular Jew is a deliberate product of the hyper-religious Jew, a monster created out of the hewed corpses of the fanatically religious Jew, a Golem which is conjured up to enter the World of the non-Jew and poison its blood, and boil its brain with a rabid lunacy that bites and spreads, until the infected community feeds on itself and fills the fields with rotting bloating bodies, where once human beings tilled the soil and tended to their families. The religious Jew created the secular Jew as an army of Esthers who seduce with open thighs, broad smiles, and a Siren call that lures in the non-Jew to cast his skull upon the jagged rocks and color the seas with his blood, sickened and blinded by the venereal disease of Judaism in secular form. Israel is not a secular democracy. It is a religious mockery. It is a rabid bat flying to the ends of the Earth, to end the Earth. No one will be free nor safe until the disease is quarantined and dies out. Source: http://www.ziopedia.org/articles/israel/how_can_israel_claim_to_be_a_%27dem… -------------------- The problem with intellectually insecure whites By Kevin MacDonald January 19, 2009 America will soon have a white minority. This is a much desired state of affairs for the hostile elites who hold political power and shape public opinion. But it certainly creates some management issues � at least in the long run. After all, it�s difficult to come up with an historical example of a nation with a solid ethnic majority (90% white in 1950) that has voluntarily decided to cede political and cultural power. Such transformations are typically accomplished by military invasions, great battles, and untold suffering. And it�s not as if everyone is doing it. Only Western nations view their own demographic and cultural eclipse as a moral imperative. Indeed, as I have noted previously, it is striking that racial nationalism has triumphed in Israel at the same time that the Jewish intellectual and political movements and the organized Jewish community have been the most active and effective force for a non-white America. Indeed, a poll in 2008 found that Avigdor Lieberman was the second most popular politician in Israel. Lieberman has advocated expulsion of Arabs from Israel and has declared himself a follower of Vladimir Jabotinsky, the leading pioneer of racial Zionism. The most popular politician in the poll was Benjamin Netanyahu � another admirer of Jabotinsky. Prime Minister Ehud Olmert and Foreign Minister Tzipi Livni are also Jabotinskyists. The racial Zionists are now carrying out yet another orgy of mass murder after a starvation-inducing blockade and the usual triggering assault designed to provoke Palestinian retaliation � which then becomes the cover for claims that Israel is merely defending itself against terrorism. This monstrosity was approved by overwhelming majorities of both Houses of Congress. The craven Bush administration did its part by abstaining from a UN resolution designed by the US Secretary of State as a result of a personal appeal by the Israeli Prime Minister. This is yet another accomplishment of the Israel Lobby, but one they would rather not have discussed in public. People might get the impression that the Lobby really does dictate US foreign policy in the Mideast. Obviously, such thoughts are only entertained by anti-Semites. But I digress. In managing the eclipse of white America, one strategy of the mainstream media is to simply ignore the issue. Christopher Donovan (�For the media, the less whites think about their coming minority status, the better�) has noted that the media, and in particular, the New York Times, are quite uninterested in doing stories that discuss what white people think about this state of affairs. It�s not surprising that the New York Times � the Jewish-owned flagship of anti-white, pro-multicultural media � ignores the issue. The issue is also missing from so-called conservative media even though one would think that conservatives would find the eclipse of white America to be an important issue. Certainly, their audiences would find it interesting. Now we have an article �The End of White America� written by Hua Hsu, an Assistant Professor of English at Vassar College. The article is a rather depressing display of what passes for intellectual discourse on the most important question confronting white people in America. Hsu begins by quoting a passage in F. Scott Fitzgerald�s The Great Gatsby in which a character, Tom Buchanan, states: �Have you read The Rise of the Colored Empires by this man Goddard?� � Well, it�s a fine book, and everybody ought to read it. The idea is if we don�t look out the white race will be�will be utterly submerged. It�s all scientific stuff; it�s been proved.� Buchanan�s comment is a thinly veiled reference to Lothrop Stoddard�s The Rising Tide of Color which Hsu describes as �rationalized hatred� presented in a scholarly, gentlemanly, and scientific tone. (This wording that will certainly help him when he comes up for tenure.) As Hsu notes, Stoddard had a doctorate from Harvard and was a member of many academic associations. His book was published by a major publisher. It was therefore �precisely the kind of book that a 1920s man of Buchanan�s profile � wealthy, Ivy League�educated, at once pretentious and intellectually insecure � might have been expected to bring up in casual conversation.� Let�s ponder that a bit. The simple reality is that in the year 2009 an Ivy League-educated person, "at once pretentious and intellectually insecure," would just as glibly assert the same sort of nonsense as Hsu. To wit: The coming white minority does not mean that the racial hierarchy of American culture will suddenly become inverted, as in 1995�s White Man�s Burden, an awful thought experiment of a film, starring John Travolta, that envisions an upside-down world in which whites are subjugated to their high-class black oppressors. There will be dislocations and resentments along the way, but the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone�s lives, producing a culture that�s more likely than any before to treat its inhabitants as individuals, rather than members of a caste or identity group. The fact is that no one can say for certain what multicultural America without a white majority will be like. There is no scientific or historical basis for claims like �the demographic shifts of the next 40 years are likely to reduce the power of racial hierarchies over everyone�s lives, producing a culture that�s more likely than any before to treat its inhabitants as individuals, rather than members of a caste or identity group.� Indeed, there is no evidence at all that we are proceeding to a color blind future. The election results continue to show that white people are coalescing in the Republican Party, while the Democrats are increasingly the party of a non-white soon-to-be majority. Is it so hard to believe that when this coalition achieves a majority that it will further compromise the interests of whites far beyond contemporary concerns such as immigration policy and affirmative action? Hsu anticipates a colorblind world, but affirmative action means that blacks and other minorities are certainly not treated as individuals. And it means that whites � especially white males � are losing out on opportunities they would have had without these policies and without the massive non-white immigration of the last few decades. Given the intractability of changing intelligence and other traits required for success in the contemporary economy, it is unlikely that 40 more years of affirmative action will attain the outcomes desired by the minority lobbies. Indeed, in Obama's America, blacks are rioting in Oakland over perceived racial injustices, and from 2002 �2007, black juvenile homicide victims increased 31%, while black juvenile homicide perpetrators increased 43%. Hence, the reasonable outlook is for a continuing need for affirmative action and for racial activism in these groups, even after whites become a minority. Whites will also lose out because of large-scale importation of relatively talented immigrants from East Asia. Indeed, as I noted over a decade ago, "The United States is well on the road to being dominated by an Asian technocratic elite and a Jewish business, professional, and media elite." Hsu shows that there already is considerable anxiety among whites about the future. An advertizing executive says, �I think white people feel like they�re under siege right now � like it�s not okay to be white right now, especially if you�re a white male. ... People are stressed out about it. �We used to be in control! We�re losing control�� Another says, "There�s a lot of fear and a lot of resentment." It's hard to see why these feelings won't increase in the future. A huge problem for white people is lack of intellectual and cultural confidence. Hsu quotes Christian (Stuff White People Like) Lander saying, "I get it: as a straight white male, I�m the worst thing on Earth." A professor comments that for his students "to be white is to be culturally broke. The classic thing white students say when you ask them to talk about who they are is, �I don�t have a culture.� They might be privileged, they might be loaded socioeconomically, but they feel bankrupt when it comes to culture � They feel disadvantaged, and they feel marginalized." This lack of cultural confidence is no accident. For nearly 100 years whites have been subjected to a culture of critique emanating from the most prestigious academic and media institutions. And, as Hsu points out, the most vibrant and influential aspect of American popular culture is hip-hop�a product of the African American urban culture. The only significant group of white people with any cultural confidence centers itself around country music, NASCAR, and the small town values of traditional white America. For this group of whites � and only this group � there is "a racial pride that dares not speak its name, and that defines itself through cultural cues instead�a suspicion of intellectual elites and city dwellers, a preference for folksiness and plainness of speech (whether real or feigned), and the association of a working-class white minority with 'the real America.'� This is what I term implicit whiteness � implicit because explicit assertions of white identity have been banned by the anti-white elites that dominate our politics and culture. It is a culture that, as Hsu notes, "cannot speak its name." But that implies that the submerged white identity of the white working class and the lack of cultural confidence exhibited by the rest of white America are imposed from outside. Although there may well be characteristics of whites that facilitate this process, this suppression of white identity and interests is certainly not the natural outcome of modernization or any other force internal to whites as a people. In my opinion, it is the result of the successful erection of a culture of critique in the West dominated by Jewish intellectual and political movements. The result is that educated, intellectually insecure white people these days are far more likely to believe in the utopian future described by Hsu than in hard and cautious thinking about what the future might have in store for them. It's worth dwelling a bit on the intellectual insecurity of the whites who mindlessly utter the mantras of multiculturalism that they have soaked up from the school system and from the media. Most people do not have much confidence in their intellectual ability and look to elite opinion to shape their beliefs. As I noted elsewhere, A critical component of the success of the culture of critique is that it achieved control of the most prestigious and influential institutions of the West, and it became a consensus among the elites, Jewish and non-Jewish alike. Once this happened, it is not surprising that this culture became widely accepted among people of very different levels of education and among people of different social classes. Most people are quite insecure about their intellectual ability. But they know that the professors at Harvard, and the editorial page of the New York Times and the Washington Post, and even conservative commentators like Rush Limbaugh and Sean Hannity are all on page when it comes to racial and ethnic issues. This is a formidable array, to the point that you almost have to be a crank to dissent from this consensus. I think one of the greatest triumphs of the left has been to get people to believe that people who assert white identity and interests or who make unflattering portrayals of organized Jewish movements are morally degenerate, stupid, and perhaps psychiatrically disturbed. Obviously, all of these adjectives designate low status. The reality is that the multicultural emperor has no clothes and, because of its support for racial Zionism and the racialism of ethnic minorities in America, it is massively hypocritical to boot. The New York Times, the academic left, and the faux conservatives that dominate elite discourse on race and ethnicity are intellectually bankrupt and can only remain in power by ruthlessly suppressing or ignoring the scientific findings. This is particularly a problem for college-educated whites. Like Fitzgerald's Tom Buchanan, such people have a strong need to feel that their ideas are respectable and part of the mainstream. But the respectable mainstream gives them absolutely nothing with which to validate themselves except perhaps the idea that the world will be a better place when people like them no longer have power. Hsu quotes the pathetic Christian Lander: "�Like, I�m aware of all the horrible crimes that my demographic has done in the world. ... And there�s a bunch of white people who are desperate � desperate � to say, �You know what? My skin�s white, but I�m not one of the white people who�s destroying the world.�� As a zombie leftist during the 1960s and 1970s, I know what that feeling of desperation is like � what it's like to be a self-hating white. We must get to the point where college-educated whites proudly and confidently say they are white and that they do not want to become a minority in America. This reminds me of the recent docudrama Milk, which depicts the life of gay activist Harvey Milk. Milk is sure be nominated for an Oscar as Best Picture because it lovingly illustrates a triumph of the cultural left. But is has an important message that should resonate with the millions of whites who have been deprived of their confidence and their culture: Be explicit. Just as Harvey Milk advocated being openly gay even in the face of dire consequences, whites need to tell their family and their friends that they have an identity as a white person and believe that whites have legitimate interests as white people. They must accept the consequences when they are harassed, fired from their jobs, or put in prison for such beliefs. They must run for political office as openly pro-white. Milk shows that homosexuals were fired from their jobs and arrested for congregating in public. Now it's the Southern Poverty Law Center and the rest of the leftist intellectual and political establishment that harasses and attempts to get people fired. But it's the same situation with the roles reversed. No revolution was ever accomplished without some martyrs. The revolution that restores the legitimacy of white identity and the legitimacy of white interests will be no exception. But it is a revolution that is absolutely necessary. The white majority is foolish indeed to entrust its future to a utopian hope that racial and ethnic identifications will disappear and that they won�t continue to influence public policy in ways that compromise the interests of whites. It does not take an overactive imagination to see that coalitions of minority groups could compromise the interests of formerly dominant whites. We already see numerous examples in which coalitions of minority groups attempt to influence public policy, including immigration policy, against the interests of the whites. Placing ourselves in a position of vulnerability would be extremely risky, given the deep sense of historical grievance fostered by many ethnic activists and organized ethnic lobbies. This is especially the case with Jews. Jewish organisations have been unanimous in condemning Western societies, Western traditions, and Christianity, for past crimes against Jews. Similar sentiments are typical of a great many African Americans and Latinos, and especially among the ethnic activists from these groups. The �God damn America� sermon by President Obama's pastor comes to mind as a recent notorious example. The precedent of the early decades of the Soviet Union should give pause to anyone who believes that surrendering ethnic hegemony does not carry risks. The Bolshevik revolution had a pronounced ethnic angle: To a very great extent, Jews and other non-Russians ruled over the Russian people, with disastrous consequences for the Russians and other ethnic groups that were not able to become part of the power structure. Jews formed a hostile elite within this power structure � as they will in the future white-minority America; Jews were �Stalin�s willing executioners.� Two passages from my review of Yuri Slezkine's The Jewish Century seem particularly appropriate here. The first passage reminds me of the many American Jews who adopt a veneer of support for leftist versions of social justice and racial tolerance while nevertheless managing to support racial Zionism and the mass murder, torture, and incarceration of the Palestinian people in one of the largest prison systems the world has ever seen. Such people may be very different when they become a hostile elite in a white-minority America. Many of the commentators on Jewish Bolsheviks noted the �transformation� of Jews [after the Bolshevik Revolution]. In the words of [a] Jewish commentator, G. A. Landau, �cruelty, sadism, and violence had seemed alien to a nation so far removed from physical activity.� And another Jewish commentator, Ia. A. Bromberg, noted that: the formerly oppressed lover of liberty had turned into a tyrant of �unheard-of-despotic arbitrariness��. The convinced and unconditional opponent of the death penalty not just for political crimes but for the most heinous offenses, who could not, as it were, watch a chicken being killed, has been transformed outwardly into a leather-clad person with a revolver and, in fact, lost all human likeness. ... After the Revolution, ... there was active suppression of any remnants of the older order and their descendants. ... The mass murder of peasants and nationalists was combined with the systematic exclusion of the previously existing non-Jewish middle class. The wife of a Leningrad University professor noted, �in all the institutions, only workers and Israelites are admitted; the life of the intelligentsia is very hard� (p. 243). Even at the end of the 1930s, prior to the Russification that accompanied World War II, �the Russian Federation�was still doing penance for its imperial past while also serving as an example of an ethnicity-free society� (p. 276). While all other nationalities, including Jews, were allowed and encouraged to keep their ethnic identities, the revolution remained an anti-majoritarian movement. The difference from the Soviet Union may well be that in white-minority America it will not be workers and Israelites who are favored, but non-whites and Israelites. Whites may dream that they are entering the post-racial utopia imagined by their erstwhile intellectual superiors. But it is quite possible that they are entering into a racial dystopia of unimaginable cruelty in which whites will be systematically excluded in favor of the new elites recruited from the soon-to-be majority. It's happened before. Kevin MacDonald is a professor of psychology at California State University�Long Beach. Permanent URL with hyperlinks: http://www.theoccidentalobserver.net/articles/MacDonald-Hsu.html ----------- Should Christians Support Israeli Terrorism in Gaza? A timely discussion between Rev. Ted Pike and Dr. David Duke, one especially important for the Christians in our audience http://www.davidduke.com/mp3/dukeradio090122DukeandPikeonGaza.mp3 In this vital discussion, Rev. Pike and Dr. Duke explore the Pro-Israel attitude of some Christian evangelical organizations, and why their position not only goes directly against Christian morality and decency, but actually is directly opposite of that expressed by Christian Scriptures. Today, Many Christians are instructed that Jews and today�s Israel has a special covenant� with God. In fact, the New Testament in the clearest of language states that the Jews �continued not in my covenant, and I considered them not, saith the Lord.� Here�s the quote that Christians aren�t supposed to notice.: 8:10 Not according to the covenant that I made with their fathers, in the day when I took them by the hand out of the land of Egypt; because they continued not in my covenant, and I regarded them not, saith the Lord. (Hebrews 8:10) They also don�t seem to notice that a 2000 year old Judaic war against Christianity that has been waged since time of Jesus Christ and still goes on today with the most powerful Jewish organizations attempting to destroy European and American traditions, that has even become a war on our Christmas traditions. Dr. Duke and Ted Pike also speak about how over a hundred thousand Christian Palestinians have suffered with their families from anti-Christian Israel! Christian support of Israel has resulted in the very birthplace of Jesus Christ, go from 90 percent Palestinian Christians to 35 percent today because of Israeli terror and occupation. They ask, �How could any Christian in good conscience support the anti-Christian state of Israel, bombing the homes, killing and maiming, torturing and oppressing fellow Christian men, women and children?� This is a vital show for every Christian reader and listener of DavidDuke.com. Next time, you hear someone say, �God tells us that we must support Israel� you will have the clear Christian answer that just the opposite is true! For documentation on this be sure to read some of the well-footnoted, sample chapters of Jewish Supremacism and My Awakening. Source : http://www.davidduke.com/general/should-christians-support-israeli-terroris… ------------------------------------- You or someone using your email adress is currently subscribed to the Lawrence Auster Newletter. If you wish to unsubscribe from our mailing list, please let us know by calling to 1 212 865 1284 Thanks, Lawrence Auster, 238 W 101 St Apt. 3B New York, NY 10025 Contact: lawrence.auster(a)att.net -------------------------------------

1 0

[cl-cairo2-cvs] r20 - tutorial
by tpapp＠common-lisp.net 28 May '08

28 May '08

Author: tpapp Date: Tue May 27 21:34:00 2008 New Revision: 20 Modified: cl-cairo2-swig.lisp package.lisp surface.lisp tables.lisp tutorial/example.lisp tutorial/hearts.png Log: added image-surface-get-data and minor fixes by Johann Korndoerfer Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Tue May 27 21:34:00 2008 @@ -83,9 +83,9 @@ (cl:defconstant CAIRO_VERSION_MAJOR 1) -(cl:defconstant CAIRO_VERSION_MINOR 4) +(cl:defconstant CAIRO_VERSION_MINOR 6) -(cl:defconstant CAIRO_VERSION_MICRO 14) +(cl:defconstant CAIRO_VERSION_MICRO 4) (cl:defconstant CAIRO_HAS_SVG_SURFACE 1) @@ -141,7 +141,9 @@ :CAIRO_STATUS_INVALID_DASH :CAIRO_STATUS_INVALID_DSC_COMMENT :CAIRO_STATUS_INVALID_INDEX - :CAIRO_STATUS_CLIP_NOT_REPRESENTABLE) + :CAIRO_STATUS_CLIP_NOT_REPRESENTABLE + :CAIRO_STATUS_TEMP_FILE_ERROR + :CAIRO_STATUS_INVALID_STRIDE) (cffi:defcenum cairo_content_t (:CAIRO_CONTENT_COLOR #x1000) @@ -401,6 +403,13 @@ (cffi:defcfun ("cairo_close_path" cairo_close_path) :void (cr :pointer)) +(cffi:defcfun ("cairo_path_extents" cairo_path_extents) :void + (cr :pointer) + (x1 :pointer) + (y1 :pointer) + (x2 :pointer) + (y2 :pointer)) + (cffi:defcfun ("cairo_paint" cairo_paint) :void (cr :pointer)) @@ -680,7 +689,7 @@ :CAIRO_FONT_TYPE_TOY :CAIRO_FONT_TYPE_FT :CAIRO_FONT_TYPE_WIN32 - :CAIRO_FONT_TYPE_ATSUI) + :CAIRO_FONT_TYPE_QUARTZ) (cffi:defcfun ("cairo_font_face_get_type" cairo_font_face_get_type) cairo_font_type_t (font_face :pointer)) @@ -768,6 +777,9 @@ (cffi:defcfun ("cairo_get_antialias" cairo_get_antialias) cairo_antialias_t (cr :pointer)) +(cffi:defcfun ("cairo_has_current_point" cairo_has_current_point) :int + (cr :pointer)) + (cffi:defcfun ("cairo_get_current_point" cairo_get_current_point) :void (cr :pointer) (x :pointer) @@ -881,7 +893,9 @@ :CAIRO_SURFACE_TYPE_BEOS :CAIRO_SURFACE_TYPE_DIRECTFB :CAIRO_SURFACE_TYPE_SVG - :CAIRO_SURFACE_TYPE_OS2) + :CAIRO_SURFACE_TYPE_OS2 + :CAIRO_SURFACE_TYPE_WIN32_PRINTING + :CAIRO_SURFACE_TYPE_QUARTZ_IMAGE) (cffi:defcfun ("cairo_surface_get_type" cairo_surface_get_type) cairo_surface_type_t (surface :pointer)) @@ -940,6 +954,12 @@ (x_pixels_per_inch my-double) (y_pixels_per_inch my-double)) +(cffi:defcfun ("cairo_surface_copy_page" cairo_surface_copy_page) :void + (surface :pointer)) + +(cffi:defcfun ("cairo_surface_show_page" cairo_surface_show_page) :void + (surface :pointer)) + (cffi:defcenum cairo_format_t :CAIRO_FORMAT_ARGB32 :CAIRO_FORMAT_RGB24 @@ -951,6 +971,10 @@ (width :int) (height :int)) +(cffi:defcfun ("cairo_format_stride_for_width" cairo_format_stride_for_width) :int + (format cairo_format_t) + (width :int)) + (cffi:defcfun ("cairo_image_surface_create_for_data" cairo_image_surface_create_for_data) :pointer (data :pointer) (format cairo_format_t) @@ -1207,6 +1231,10 @@ (cffi:defcfun ("cairo_ft_scaled_font_unlock_face" cairo_ft_scaled_font_unlock_face) :void (scaled_font :pointer)) +(cffi:defcenum cairo_ps_level_t + :CAIRO_PS_LEVEL_2 + :CAIRO_PS_LEVEL_3) + (cffi:defcfun ("cairo_ps_surface_create" cairo_ps_surface_create) :pointer (filename :string) (width_in_points my-double) @@ -1218,6 +1246,24 @@ (width_in_points my-double) (height_in_points my-double)) +(cffi:defcfun ("cairo_ps_surface_restrict_to_level" cairo_ps_surface_restrict_to_level) :void + (surface :pointer) + (level cairo_ps_level_t)) + +(cffi:defcfun ("cairo_ps_get_levels" cairo_ps_get_levels) :void + (levels :pointer) + (num_levels :pointer)) + +(cffi:defcfun ("cairo_ps_level_to_string" cairo_ps_level_to_string) :string + (level cairo_ps_level_t)) + +(cffi:defcfun ("cairo_ps_surface_set_eps" cairo_ps_surface_set_eps) :void + (surface :pointer) + (eps :int)) + +(cffi:defcfun ("cairo_ps_surface_get_eps" cairo_ps_surface_get_eps) :int + (surface :pointer)) + (cffi:defcfun ("cairo_ps_surface_set_size" cairo_ps_surface_set_size) :void (surface :pointer) (width_in_points my-double) @@ -1241,6 +1287,9 @@ (width :int) (height :int)) +(cffi:defcfun ("cairo_xlib_surface_get_xrender_format" cairo_xlib_surface_get_xrender_format) :pointer + (surface :pointer)) + (cffi:defcfun ("cairo_pdf_surface_create" cairo_pdf_surface_create) :pointer (filename :string) (width_in_points my-double) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Tue May 27 21:34:00 2008 @@ -14,6 +14,7 @@ destroy create-ps-surface create-pdf-surface create-svg-surface create-image-surface image-surface-get-format image-surface-get-width image-surface-get-height + image-surface-get-data image-surface-create-from-png surface-write-to-png ;; context Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Tue May 27 21:34:00 2008 @@ -113,6 +113,25 @@ width height) width height t)) +(defun get-bytes-per-pixel (format) + (case format + (format-argb32 4) + (format-rgb24 3) + (format-a8 1) + (otherwise (error (format nil "unknown format: ~a" format))))) ;todo: how does format-a1 fit in here? + +(defun image-surface-get-data (surface) + (with-surface (surface pointer) + (let* ((width (image-surface-get-width surface)) + (height (image-surface-get-height surface)) + (bytes-per-pixel (get-bytes-per-pixel (image-surface-get-format surface))) + (buffer (make-array (* width height bytes-per-pixel) :element-type '(unsigned-byte 8) :fill-pointer 0)) + (data (cairo_image_surface_get_data pointer))) + (loop for i from 0 below (* width height bytes-per-pixel) do + (vector-push-extend (cffi:mem-ref data :uint8 i) buffer)) + buffer))) + + (defun image-surface-get-format (surface) (with-surface (surface pointer) (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))) Modified: tables.lisp ============================================================================== --- tables.lisp (original) +++ tables.lisp Tue May 27 21:34:00 2008 @@ -112,5 +112,5 @@ (defun lookup-enum (enum table) (let ((cairo-enum (car (rassoc enum table)))) (unless cairo-enum - (error "Could not find ~a in ~a." cairo-enum table)) + (error "Could not find ~a in ~a." enum table)) cairo-enum)) Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Tue May 27 21:34:00 2008 @@ -39,6 +39,79 @@ (- y (* height y-align) y-bearing)) (show-text text)))) +;;;; very simple text example +(setf *context* (create-ps-context "simpletext.ps" 100 100)) +(move-to 0 100) +(set-font-size 50) +(show-text "foo") +(destroy *context*) + + +;;;; +;;;; text placement example +;;;; +;;;; This example demonstrates the use of text-extents, by placing +;;;; text aligned relative to a red marker. + +(defun mark-at (x y d red green blue) + "Make a rectangle of size 2d around x y with the given colors, + 50% alpha. Used for marking points." + (rectangle (- x d) (- y d) (* 2 d) (* 2 d)) + (set-source-rgba red green blue 0.5) + (fill-path)) + +(defun show-text-with-marker (text x y x-align y-align) + "Show text aligned relative to a red market at (x,y)." + (mark-at x y 2 1 0 0) + (set-source-rgba 0 0 0 0.6) + (show-text-aligned text x y x-align y-align)) + +(defparameter width 500) +(defparameter height 500) +(defparameter text "Fog") ; contains g, which goes below baseline +(defparameter size 50) +(defparameter x 20d0) +(defparameter y 50d0) +(setf *context* (create-ps-context "text.ps" width height)) +;;(setf *context* (create-svg-context "text.svg" width height)) +;;(setf *context* (create-pdf-context "text.pdf" width height)) +;; white background +(set-source-rgb 1 1 1) +(paint) +;; setup font +(select-font-face "Arial" 'font-slant-normal 'font-weight-normal) +(set-font-size size) +;; starting point +(mark-at x y 2 1 0 0) ; red +;; first text in a box +(multiple-value-bind (x-bearing y-bearing text-width text-height) + (text-extents text) + (let ((rect-x (+ x x-bearing)) + (rect-y (+ y y-bearing))) + (rectangle rect-x rect-y text-width text-height) + (set-source-rgba 0 0 1 0.3) ; blue + (set-line-width 1) + (set-dash 0 '(5 5)) + (stroke))) +(set-source-rgba 0 0 0 0.6) +(move-to x y) +(show-text text) +;; text automatically aligned +;; (dolist (x-align '(0 0.5 1)) +;; (dolist (y-align '(0 0.5 1)) +;; (show-text-with-marker text (+ x (* x-align 300)) (+ y (* y-align 300) 100) +;; x-align y-align))) +(dolist (x-align '(0)) + (dolist (y-align '(0)) + (show-text-with-marker text (+ x (* x-align 300)) (+ y (* y-align 300) 100) + x-align y-align))) + +(show-text-with-marker text x (+ y 100d0) 0d0 0d0) +;; done +(destroy *context*) + + + ;;;; ;;;; text placement example ;;;; @@ -64,7 +137,9 @@ (defparameter size 50) (defparameter x 20) (defparameter y 50) -(setf *context* (create-ps-context "text.ps" width height)) +(setf *context* (create-ps-context "text2.ps" width height)) +;;(setf *context* (create-svg-context "text.svg" width height)) +;;(setf *context* (create-pdf-context "text.pdf" width height)) ;; white background (set-source-rgb 1 1 1) (paint) @@ -91,6 +166,9 @@ (dolist (y-align '(0 0.5 1)) (show-text-with-marker text (+ x (* x-align 300)) (+ y (* y-align 300) 100) x-align y-align))) + +(show-text-with-marker text (+ x 0d0) (+ y 0d0 0d0) 0d0 0d0) + ;; done (destroy *context*) Modified: tutorial/hearts.png ============================================================================== Binary files. No diff available.

1 0

[cl-cairo2-cvs] r19 - tutorial
by tpapp＠common-lisp.net 21 Apr '08

21 Apr '08

Author: tpapp Date: Mon Apr 21 09:01:57 2008 New Revision: 19 Modified: cl-cairo2-swig.lisp cl-cairo2.i tutorial/hearts.png Log: fixed my-double type coercion to work with new CFFI Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Mon Apr 21 09:01:57 2008 @@ -1,11 +1,15 @@ (in-package :cl-cairo2) -(defctype my-double :double) -;; (defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) -;; `(coerce ,value 'double-float)) -(defmethod translate-to-foreign (value (type (eql 'my-double))) - (coerce value 'double-float)) +;; define our own alias for double float, so we can automatically +;; convert other numerical types in the arguments +(define-foreign-type my-double-type () + () + (:actual-type :double) + (:simple-parser my-double)) + +(defmethod translate-to-foreign (value (type my-double-type)) + (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots Modified: cl-cairo2.i ============================================================================== --- cl-cairo2.i (original) +++ cl-cairo2.i Mon Apr 21 09:01:57 2008 @@ -9,11 +9,15 @@ %insert("lisphead") %{ (in-package :cl-cairo2) -(defctype my-double :double) -;; (defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) -;; `(coerce ,value 'double-float)) -(defmethod translate-to-foreign (value (type (eql 'my-double))) - (coerce value 'double-float)) +;; define our own alias for double float, so we can automatically +;; convert other numerical types in the arguments +(define-foreign-type my-double-type () + () + (:actual-type :double) + (:simple-parser my-double)) + +(defmethod translate-to-foreign (value (type my-double-type)) + (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots Modified: tutorial/hearts.png ============================================================================== Binary files. No diff available.

1 0

[cl-cairo2-cvs] r18 -
by tpapp＠common-lisp.net 20 Apr '08

20 Apr '08

Author: tpapp Date: Sun Apr 20 19:37:41 2008 New Revision: 18 Modified: cl-cairo2-swig.lisp Log: Regenerated SWIG file. Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Sun Apr 20 19:37:41 2008 @@ -81,7 +81,7 @@ (cl:defconstant CAIRO_VERSION_MINOR 4) -(cl:defconstant CAIRO_VERSION_MICRO 10) +(cl:defconstant CAIRO_VERSION_MICRO 14) (cl:defconstant CAIRO_HAS_SVG_SURFACE 1)

1 0

[cl-cairo2-cvs] r17 - tutorial
by tpapp＠common-lisp.net 23 Mar '08

23 Mar '08

Author: tpapp Date: Sun Mar 23 17:58:24 2008 New Revision: 17 Added: tutorial/hearts.png (contents, props changed) Modified: cl-cairo2.asd context.lisp package.lisp surface.lisp tutorial/Makefile xlib-context.lisp xlib-image-context.lisp xlib.lisp Log: Several small changes: - dependence on trivial-garbage for finalizer code - fixes in examples/Makefile Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Sun Mar 23 17:58:24 2008 @@ -3,7 +3,7 @@ (in-package :cl-cairo2-asd) -(defsystem cl-cairo2 +(defsystem #:cl-cairo2 :description "Cairo 1.4 bindings" :version "0.3" :author "Tamas K Papp" @@ -26,4 +26,4 @@ (:file "gtk-context" :depends-on ("context") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) - :depends-on (:cffi :cl-colors :cl-utilities)) + :depends-on (:cffi :cl-colors :cl-utilities :trivial-garbage)) Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Sun Mar 23 17:58:24 2008 @@ -25,19 +25,28 @@ (defclass context () ((pointer :initform nil :initarg :pointer) (width :initarg :width :reader get-width) - (height :initarg :height :reader get-height))) + (height :initarg :height :reader get-height) + (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p))) + +(defmethod print-object ((obj context) stream) + "Print a canvas object." + (print-unreadable-object (obj stream :type t) + (with-slots (pointer width height pixel-based-p) obj + (format stream "pointer: ~a, width: ~a, height: ~a, pixel-based-p: ~a" + pointer width height pixel-based-p)))) (defun create-context (surface) (with-surface (surface pointer) (let ((context (make-instance 'context :pointer (cairo_create pointer) :width (get-width surface) - :height (get-height surface)))) + :height (get-height surface) + :pixel-based-p (pixel-based-p surface)))) ;; register finalizer (let ((context-pointer (slot-value context 'pointer))) - (finalize context - #'(lambda () - (cairo_destroy context-pointer)))) + (tg:finalize context + #'(lambda () + (cairo_destroy context-pointer)))) ;; return context context))) @@ -47,7 +56,7 @@ (cairo_destroy pointer) (setf pointer nil))) ;; deregister finalizer - (cancel-finalization object)) + (tg:cancel-finalization object)) (defgeneric sync (object) (:documentation "Synchronize contents of the object with the @@ -82,6 +91,18 @@ (defvar *context* nil "default cairo context") +(defmacro with-png-file ((filename format width height) &body body) + "Execute the body with context bound to a newly created png + file, and close it after executing body." + (let ((surface-name (gensym))) + `(let* ((,surface-name (create-image-surface ,format ,width ,height)) + (*context* (create-context ,surface-name))) + (progn + ,@body + (surface-write-to-png ,surface-name ,filename) + (destroy ,surface-name) + (destroy *context*))))) + (defmacro with-context ((context pointer) &body body) "Execute body with pointer pointing to context, and check status." (let ((status (gensym)) @@ -260,6 +281,19 @@ ;;;; convenience functions for creating contexts directly ;;;; +(defmacro define-create-context (type) + `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") + (filename width height) + "Create a surface, then a context for a file, then +destroy (dereference) the surface. The user only needs to +destroy the context when done." + (let* ((surface (,(prepend-intern "create-" + type :replace-dash nil :suffix "-surface") + filename width height)) + (context (create-context surface))) + (destroy surface) + context))) + (define-create-context ps) (define-create-context pdf) (define-create-context svg) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Sun Mar 23 17:58:24 2008 @@ -1,4 +1,6 @@ -(defpackage :cl-cairo2 +(in-package #:cl-cairo2-asd) + +(defpackage cl-cairo2 (:use :common-lisp :cffi :cl-colors :cl-utilities) (:export @@ -8,23 +10,24 @@ ;; surface - get-width get-height destroy create-ps-surface create-pdf-surface - create-svg-surface create-image-surface image-surface-get-format + surface pointer width height get-width get-height pixel-based-p + destroy create-ps-surface create-pdf-surface create-svg-surface + create-image-surface image-surface-get-format image-surface-get-width image-surface-get-height - image-surface-create-from-png surface-write-to-png with-png-file + image-surface-create-from-png surface-write-to-png ;; context - create-context sync sync-lock sync sync-unlock sync-reset - with-sync-lock *context* save restore push-group pop-group - pop-group-to-source set-source-rgb set-source-rgba clip - clip-preserve reset-clip copy-page show-page fill-preserve paint - paint-with-alpha stroke stroke-preserve set-source-color - get-line-width set-line-width get-miter-limit set-miter-limit - get-antialias set-antialias get-fill-rule set-fill-rule - get-line-cap set-line-cap get-line-join set-line-join get-operator - set-operator fill-path set-dash get-dash clip-extents fill-extents - in-fill in-stoke create-ps-context create-pdf-context + context with-png-file create-context sync sync-lock sync + sync-unlock sync-reset with-sync-lock *context* save restore + push-group pop-group pop-group-to-source set-source-rgb + set-source-rgba clip clip-preserve reset-clip copy-page show-page + fill-preserve paint paint-with-alpha stroke stroke-preserve + set-source-color get-line-width set-line-width get-miter-limit + set-miter-limit get-antialias set-antialias get-fill-rule + set-fill-rule get-line-cap set-line-cap get-line-join set-line-join + get-operator set-operator fill-path set-dash get-dash clip-extents + fill-extents in-fill in-stoke create-ps-context create-pdf-context create-svg-context get-target ;; path Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Sun Mar 23 17:58:24 2008 @@ -13,10 +13,20 @@ ;;;; class surface ;;;; +(defgeneric get-width (object) + (:documentation "return the width of an object")) + +(defgeneric get-height (object) + (:documentation "return the height of an object")) + +(defgeneric pixel-based-p (object) + (:documentation "return t iff the object uses a pixel-based backend")) + (defclass surface () ((pointer :initarg :pointer :initform nil) (width :initarg :width :reader get-width) - (height :initarg :height :reader get-height))) + (height :initarg :height :reader get-height) + (pixel-based-p :initarg :pixel-based-p :reader pixel-based-p))) (defmacro with-alive-surface ((surface pointer) &body body) "Execute body with pointer pointing to cairo surface, if nil, @@ -37,18 +47,19 @@ (warn "function returned with status ~a." ,status)))))) (defmacro with-surface ((surface pointer) &body body) - "Execute body with pointer pointing to context, and check status." + "Execute body with pointer pointing to surface, and check status." `(with-alive-surface (,surface ,pointer) (check-surface-pointer-status ,pointer ,@body))) -(defun new-surface-with-check (pointer width height) +(defun new-surface-with-check (pointer width height &optional (pixel-based-p nil)) "Check if the creation of new surface was successful, if so, return new class." - (let ((surface (make-instance 'surface :width width :height height))) + (let ((surface (make-instance 'surface :width width :height height + :pixel-based-p pixel-based-p))) (check-surface-pointer-status pointer (setf (slot-value surface 'pointer) pointer) ;; register finalizer -;; (finalize surface #'(lambda () (cairo_surface_destroy pointer))) + (tg:finalize surface #'(lambda () (cairo_surface_destroy pointer))) ;; return surface surface))) @@ -57,7 +68,7 @@ (cairo_surface_destroy pointer) (setf pointer nil)) ;; deregister finalizer - (cancel-finalization object)) + (tg:cancel-finalization object)) ;;;; ;;;; Macros to create surfaces (that are written into files) and @@ -74,19 +85,6 @@ filename width height) width height))) -(defmacro define-create-context (type) - `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") - (filename width height) - "Create a surface, then a context for a file, then -destroy (dereference) the surface. The user only needs to -destroy the context when done." - (let* ((surface (,(prepend-intern "create-" - type :replace-dash nil :suffix "-surface") - filename width height)) - (context (create-context surface))) - (destroy surface) - context))) - ;;;; ;;;; PDF surface ;;;; @@ -113,7 +111,7 @@ (new-surface-with-check (cairo_image_surface_create (lookup-enum format table-format) width height) - width height)) + width height t)) (defun image-surface-get-format (surface) (with-surface (surface pointer) @@ -144,14 +142,3 @@ (with-surface (surface pointer) (cairo_surface_write_to_png pointer filename))) -(defmacro with-png-file ((filename format width height) &body body) - "Execute the body with context bound to a newly created png - file, and close it after executing body." - (let ((surface-name (gensym))) - `(let* ((,surface-name (create-image-surface ,format ,width ,height)) - (*context* (create-context ,surface-name))) - (progn - ,@body - (surface-write-to-png ,surface-name ,filename) - (destroy ,surface-name) - (destroy *context*))))) Modified: tutorial/Makefile ============================================================================== --- tutorial/Makefile (original) +++ tutorial/Makefile Sun Mar 23 17:58:24 2008 @@ -1,8 +1,15 @@ +EXAMPLEFILES=hearts.png lissajous.epsi text.epsi example.epsi +RAWEXAMPLEFILES=hearts.png lissajous.ps text.ps example.ps +LISP=sbcl + tutorial.pdf: tutorial.dvi dvipdfm tutorial -tutorial.dvi: tutorial.tex hearts.png lissajous.epsi text.epsi example.epsi +tutorial.dvi: tutorial.tex $(EXAMPLEFILES) latex tutorial.tex +$(RAWEXAMPLEFILES): example.lisp + $(LISP) --eval '(progn (load "example.lisp") (quit))' + %.epsi: %.ps ps2epsi $< $@ Added: tutorial/hearts.png ============================================================================== Binary file. No diff available. Modified: xlib-context.lisp ============================================================================== --- xlib-context.lisp (original) +++ xlib-context.lisp Sun Mar 23 17:58:24 2008 @@ -152,8 +152,8 @@ ;; intern atom for window closing, set protocol on window (setf wm-delete-window (xinternatom display "WM_DELETE_WINDOW" 1)) - (with-foreign-object (prot 'atom) - (setf (mem-aref prot 'atom) wm-delete-window) + (with-foreign-object (prot 'xatom) + (setf (mem-aref prot 'xatom) wm-delete-window) (xsetwmprotocols display window prot 1)) ;; store name (xstorename display window window-name) Modified: xlib-image-context.lisp ============================================================================== --- xlib-image-context.lisp (original) +++ xlib-image-context.lisp Sun Mar 23 17:58:24 2008 @@ -38,16 +38,60 @@ thread (sync-counter :initform 0 :accessor sync-counter))) + +;; synchronization after drawing + +(defun send-message-to-signal-window (xlib-image-context message) + "Send the desired message to the context window." + (with-slots (pointer (display-pointer display) signal-window) xlib-image-context + (unless pointer + (warn "context is not active, can't send message to window") + (return-from send-message-to-signal-window)) + (with-foreign-object (xev :long 24) + (with-foreign-slots + ((type display window message-type format data0) + xev xclientmessageevent) + (setf type 33) ; clientnotify + (setf display display-pointer) + (setf window signal-window) + (setf message-type 0) + (setf format 32) + (setf data0 message) + (xsendevent display-pointer signal-window 0 0 xev)) + (xflush display-pointer)))) + +(defmethod sync ((object xlib-image-context)) + (when (zerop (sync-counter object)) + (send-message-to-signal-window object +refresh-message+))) + +(defmethod sync-lock ((object xlib-image-context)) + (incf (sync-counter object))) + +(defmethod sync-unlock ((object xlib-image-context)) + (with-slots (sync-counter) object + (when (plusp sync-counter) + (decf sync-counter))) + (sync object)) + +(defmethod sync-reset ((object xlib-image-context)) + (setf (sync-counter object) 0) + (sync object)) + (defun create-xlib-image-context (width height &key (display-name nil) - (window-name (next-xlib-image-context-name))) + (window-name (next-xlib-image-context-name)) + (background-color +white+)) + "Create a window mapped to an xlib-image-context, with given width, +height (non-resizable) and window-name on display-name. If +background-color is not nil, the window will be painted with it." (let ((display (xopendisplay (if display-name display-name (null-pointer))))) (when (null-pointer-p display) (error "couldn't open display ~a" display-name)) (let ((xlib-image-context (make-instance 'xlib-image-context :display display :width width - :height height))) + :height height + :pixel-based-p t))) (labels (;; Repaint the xlib context with the image surface ;; (previously set as source during initialization. (refresh () @@ -128,8 +172,8 @@ ;; intern atom for window closing, set protocol on window (setf wm-delete-window (xinternatom display "WM_DELETE_WINDOW" 1)) - (with-foreign-object (prot 'atom) - (setf (mem-aref prot 'atom) wm-delete-window) + (with-foreign-object (prot 'xatom) + (setf (mem-aref prot 'xatom) wm-delete-window) (xsetwmprotocols display window prot 1)) ;; store name (xstorename display window window-name) @@ -154,44 +198,15 @@ (start-thread #'event-loop (format nil "thread for display ~a" display-name)))))) + ;; paint it if we are given a background color + (when background-color + (set-source-color background-color xlib-image-context) + (paint xlib-image-context) + (sync xlib-image-context)) ;; return context xlib-image-context))) -(defun send-message-to-signal-window (xlib-image-context message) - "Send the desired message to the context window." - (with-slots (pointer (display-pointer display) signal-window) xlib-image-context - (unless pointer - (warn "context is not active, can't send message to window") - (return-from send-message-to-signal-window)) - (with-foreign-object (xev :long 24) - (with-foreign-slots - ((type display window message-type format data0) - xev xclientmessageevent) - (setf type 33) ; clientnotify - (setf display display-pointer) - (setf window signal-window) - (setf message-type 0) - (setf format 32) - (setf data0 message) - (xsendevent display-pointer signal-window 0 0 xev)) - (xflush display-pointer)))) (defmethod destroy ((object xlib-image-context)) (send-message-to-signal-window object +destroy-message+)) -(defmethod sync ((object xlib-image-context)) - (when (zerop (sync-counter object)) - (send-message-to-signal-window object +refresh-message+))) - -(defmethod sync-lock ((object xlib-image-context)) - (incf (sync-counter object))) - -(defmethod sync-unlock ((object xlib-image-context)) - (with-slots (sync-counter) object - (when (plusp sync-counter) - (decf sync-counter))) - (sync object)) - -(defmethod sync-reset ((object xlib-image-context)) - (setf (sync-counter object) 0) - (sync object)) Modified: xlib.lisp ============================================================================== --- xlib.lisp (original) +++ xlib.lisp Sun Mar 23 17:58:24 2008 @@ -17,7 +17,7 @@ (defctype colormap xid) (defctype graphics-context xid) (defctype visual :pointer) -(defctype atom :unsigned-long) +(defctype xatom :unsigned-long) (defctype bool :int) ;; constants @@ -255,7 +255,7 @@ ;; atoms & protocols -(defcfun ("XInternAtom" xinternatom) atom +(defcfun ("XInternAtom" xinternatom) xatom (display display) (atom-name :string) (only-if-exists :int)) @@ -304,7 +304,7 @@ (send-event bool) (display display) (window window) - (message-type atom) + (message-type xatom) (format :int) ;; we only use first field, union of message data is not included (data0 :unsigned-long))

1 0

[cl-cairo2-cvs] r16 - tutorial
by tpapp＠common-lisp.net 20 Dec '07

20 Dec '07

Author: tpapp Date: Thu Dec 20 08:17:49 2007 New Revision: 16 Added: gtk-context.lisp tutorial/test-xlib.lisp tutorial/xlib-image-context-test.lisp xlib-image-context.lisp Modified: cl-cairo2.asd package.lisp Log: added gtk-context, contributed by Peter Hildebrandt Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Dec 20 08:17:49 2007 @@ -1,3 +1,8 @@ +(defpackage #:cl-cairo2-asd + (:use :cl :asdf)) + +(in-package :cl-cairo2-asd) + (defsystem cl-cairo2 :description "Cairo 1.4 bindings" :version "0.3" @@ -17,5 +22,8 @@ (compile-op (feature :unix)))) (:file "xlib-image-context" :depends-on ("xlib") :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix)))) + (:file "gtk-context" :depends-on ("context") + :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) :depends-on (:cffi :cl-colors :cl-utilities)) Added: gtk-context.lisp ============================================================================== --- (empty file) +++ gtk-context.lisp Thu Dec 20 08:17:49 2007 @@ -0,0 +1,40 @@ +(in-package :cl-cairo2) + + +;; library functions to create a gdk-surface +;; written by Peter Hildebrandt <peter.hildebrandt(a)washbear-network.de> + +(define-foreign-library :gdk + (cffi-features:unix "libgdk-x11-2.0.so") + (cffi-features:windows "libgdk-win32-2.0-0.dll") + (cffi-features:darwin "libgdk-win32-2.0-0.dylib")) + +(load-foreign-library :gdk) +(defcfun ("gdk_cairo_create" gdk-cairo-create) :pointer (window :pointer)) + +(defclass gtk-context (context) + ()) + +(defun create-gtk-context (gdk-window) + "creates an context to draw on a GTK widget, more precisely on the +associated gdk-window. This should only be called from within the +expose event. In cells-gtk, use (gtk-adds-widget-window gtk-pointer) +to obtain the gdk-window. 'gtk-pointer' is the pointer parameter +passed to the expose event handler." + (make-instance 'gtk-context + :pointer (gdk-cairo-create gdk-window))) + +(defmethod destroy ((self gtk-context)) + (cairo_destroy (slot-value self 'pointer))) + +(defmacro with-gtk-context ((context gdk-window) &body body) + "Executes body while context is bound to a valid cairo context for +gdk-window. This should only be called from within an expose event +handler. In cells-gtk, use (gtk-adds-widget-window gtk-pointer) to +obtain the gdk-window. 'gtk-pointer' is the pointer parameter passed +to the expose event handler." + (with-gensyms (context-pointer) + `(let ((,context (create-gtk-context ,gdk-window))) + (with-context (,context ,context-pointer) + ,@body) + (destroy ,context)))) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Thu Dec 20 08:17:49 2007 @@ -1,54 +1,58 @@ (defpackage :cl-cairo2 - (:use :common-lisp :cffi :cl-colors :cl-utilities) - (:export + (:use :common-lisp :cffi :cl-colors :cl-utilities) + (:export - ;; cairo + ;; cairo - destroy deg-to-rad + destroy deg-to-rad - ;; surface - - get-width get-height destroy create-ps-surface create-pdf-surface - create-svg-surface create-image-surface image-surface-get-format - image-surface-get-width image-surface-get-height - image-surface-create-from-png surface-write-to-png with-png-file + ;; surface - ;; context + get-width get-height destroy create-ps-surface create-pdf-surface + create-svg-surface create-image-surface image-surface-get-format + image-surface-get-width image-surface-get-height + image-surface-create-from-png surface-write-to-png with-png-file - create-context sync sync-lock sync sync-unlock sync-reset - with-sync-lock *context* save restore push-group pop-group - pop-group-to-source set-source-rgb set-source-rgba clip - clip-preserve reset-clip copy-page show-page fill-preserve paint - paint-with-alpha stroke stroke-preserve set-source-color - get-line-width set-line-width get-miter-limit set-miter-limit - get-antialias set-antialias get-fill-rule set-fill-rule - get-line-cap set-line-cap get-line-join set-line-join get-operator - set-operator fill-path set-dash get-dash clip-extents fill-extents - in-fill in-stoke create-ps-context create-pdf-context - create-svg-context get-target - - ;; path - - new-path new-sub-path close-path arc arc-negative curve-to line-to - move-to rectangle rel-move-to rel-curve-to rel-line-to text-path - get-current-point - - ;; text - - select-font-face set-font-size text-extents show-text - - ;; transformations + ;; context + + create-context sync sync-lock sync sync-unlock sync-reset + with-sync-lock *context* save restore push-group pop-group + pop-group-to-source set-source-rgb set-source-rgba clip + clip-preserve reset-clip copy-page show-page fill-preserve paint + paint-with-alpha stroke stroke-preserve set-source-color + get-line-width set-line-width get-miter-limit set-miter-limit + get-antialias set-antialias get-fill-rule set-fill-rule + get-line-cap set-line-cap get-line-join set-line-join get-operator + set-operator fill-path set-dash get-dash clip-extents fill-extents + in-fill in-stoke create-ps-context create-pdf-context + create-svg-context get-target + + ;; path + + new-path new-sub-path close-path arc arc-negative curve-to line-to + move-to rectangle rel-move-to rel-curve-to rel-line-to text-path + get-current-point + + ;; text + + select-font-face set-font-size text-extents show-text + + ;; transformations + + translate scale rotate reset-trans-matrix make-trans-matrix + trans-matrix-xx trans-matrix-yx trans-matrix-xy trans-matrix-yy + trans-matrix-x0 trans-matrix-y0 trans-matrix-p transform + set-trans-matrix get-trans-matrix user-to-device + user-to-device-distance device-to-user device-to-user-distance + trans-matrix-init-translate trans-matrix-init-scale + trans-matrix-init-rotate trans-matrix-rotate trans-matrix-scale + trans-matrix-rotate trans-matrix-invert trans-matrix-multiply + trans-matrix-distance transform-point - translate scale rotate reset-trans-matrix make-trans-matrix - trans-matrix-xx trans-matrix-yx trans-matrix-xy trans-matrix-yy - trans-matrix-x0 trans-matrix-y0 trans-matrix-p transform - set-trans-matrix get-trans-matrix user-to-device - user-to-device-distance device-to-user device-to-user-distance - trans-matrix-init-translate trans-matrix-init-scale - trans-matrix-init-rotate trans-matrix-rotate trans-matrix-scale - trans-matrix-rotate trans-matrix-invert trans-matrix-multiply - trans-matrix-distance transform-point + ;; xlib-image-context - ;; xlib-image-context + xlib-image-context create-xlib-image-context - xlib-image-context create-xlib-image-context)) + ;; gtk-context + + gtk-context create-gtk-context with-gtk-context)) Added: tutorial/test-xlib.lisp ============================================================================== --- (empty file) +++ tutorial/test-xlib.lisp Thu Dec 20 08:17:49 2007 @@ -0,0 +1,51 @@ +(in-package :cl-cairo2) + +(defun random-size () + (+ 200 (random 100))) +(defparameter *list-of-contexts* nil) +(defparameter *max-number-of-contexts* 50) + +(defun x-on-window (context) + (let ((width (get-width context)) + (height (get-height context))) + ;; clear + (rectangle 0 0 width height context) + (set-source-color +white+ context) + (fill-path context) + ;; draw X + (move-to 0 0 context) + (line-to width height context) + (set-source-color +green+ context) + (stroke context) + (move-to 0 height context) + (line-to width 0 context) + (set-source-color +blue+ context) + (stroke context))) + +(defun remove-random-window (list) + (assert (not (null list))) + (let* ((length (length list)) + (index (random length)) + (context (nth index list))) + (format t "killing ~a~%" index) + (destroy context) + (remove context list))) + +;; create contexts with an x on them +(dotimes (i *max-number-of-contexts*) + (let ((context (create-xlib-image-context (random-size) (random-size)))) + (x-on-window context) + (push context *list-of-contexts*))) + +;; close all, in random order +(do () + ((not *list-of-contexts*)) + (setf *list-of-contexts* (remove-random-window *list-of-contexts*))) + + +(defparameter *c1* (create-xlib-context 100 100)) +(x-on-window *c1*) +(defparameter *c2* (create-xlib-context 140 200)) +(x-on-window *c2*) + +(destroy *c1*) Added: tutorial/xlib-image-context-test.lisp ============================================================================== --- (empty file) +++ tutorial/xlib-image-context-test.lisp Thu Dec 20 08:17:49 2007 @@ -0,0 +1,27 @@ +(in-package :cl-cairo2) + +(setf *context* (create-xlib-image-context 400 200 :display-name ":0")) +(move-to 0 0) +(line-to 400 200) +(set-source-color +green+) +(stroke) + +(let* ((display (slot-value *context* 'display)) + (screen (xdefaultscreen display)) + (depth (xdefaultdepth display screen))) + depth) + +(with-foreign-slots ((width height format data + byte-order bitmap-unit + bitmap-bit-order bitmap-pad + depth bytes-per-line + bits-per-pixel red-mask + green-mask blue-mask + xoffset) (slot-value *context* 'ximage) ximage) + (values width height format data + byte-order bitmap-unit + bitmap-bit-order bitmap-pad + depth bytes-per-line + bits-per-pixel red-mask + green-mask blue-mask + xoffset)) Added: xlib-image-context.lisp ============================================================================== --- (empty file) +++ xlib-image-context.lisp Thu Dec 20 08:17:49 2007 @@ -0,0 +1,197 @@ +(in-package :cl-cairo2) + +;; constants for communicating with the signal window +(defconstant +destroy-message+ 4072) ; just some random constant +(defconstant +refresh-message+ 2495) ; ditto + +(defvar *xlib-image-context-count* 0 "window counter for autogenerating names") + +(defun next-xlib-image-context-name () + "Return an autogenerated window name using *xlib-context-count*." + (format nil "cl-cairo2 ~a" (incf *xlib-image-context-count*))) + +;; code to make threads, please extend with your own Lisp if needed +;; testing is welcome, I only tested cmucl and sbcl +(defun start-thread (function name) + #+allegro (mp:process-run-function name function) + #+armedbear (ext:make-thread function :name name) + #+cmu (mp:make-process function :name name) + #+lispworks (mp:process-run-function name nil function) + #+openmcl (ccl:process-run-function name function) + #+sbcl (sb-thread:make-thread function :name name)) + +;; we create this definition manually, SWIG just messes things up +(defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t + (display display) + (drawable drawable) + (visual visual) + (width :int) + (height :int)) + +(defclass xlib-image-context (context) + ((display :initarg :display) + window graphics-context signal-window + (xlib-context :accessor xlib-context) + wm-delete-window + (width :initarg :width) + (height :initarg :height) + thread + (sync-counter :initform 0 :accessor sync-counter))) + +(defun create-xlib-image-context (width height &key + (display-name nil) + (window-name (next-xlib-image-context-name))) + (let ((display (xopendisplay (if display-name display-name (null-pointer))))) + (when (null-pointer-p display) + (error "couldn't open display ~a" display-name)) + (let ((xlib-image-context (make-instance 'xlib-image-context + :display display + :width width + :height height))) + (labels (;; Repaint the xlib context with the image surface + ;; (previously set as source during initialization. + (refresh () + (cairo_paint (xlib-context xlib-image-context))) + ;; The main event loop, started as a separate thread + ;; when initialization is complete. The main thread is + ;; supposed to communicate with this one via X signals + ;; using an unmapped InputOnly window (see + ;; send-message-to-signal-window). + (event-loop () + (with-slots (display (this-window window) signal-window + wm-delete-window graphics-context) + xlib-image-context + (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1))) + (with-foreign-object (xev :long 24) + (do ((got-close-signal nil)) + (got-close-signal) + ;; get next event + (xnextevent display xev) + ;; decipher structure, at least partially + (with-foreign-slots ((type window serial) xev xanyevent) + ;; action based on event type + (cond + ;; expose events + ((and (= type 12) (= window this-window)) + (refresh)) + ;; clientnotify event + ((= type 33) + (with-foreign-slots ((message-type data0) xev + xclientmessageevent) + (cond + ((or (and (= window signal-window) + (= data0 +destroy-message+)) + (and (= window this-window) + (= message-type wm-protocols) + (= data0 wm-delete-window))) + (setf got-close-signal t)) + ((and (= window signal-window) + (= data0 +refresh-message+)) + (refresh))))))))))) + ;; close down everything + (with-slots (display pixmap window signal-window pointer + xlib-context) + xlib-image-context + (xsynchronize display 1) + (let ((saved-pointer pointer)) + (setf pointer nil) ; invalidate first so it can't be used + (cairo_destroy saved-pointer)) + (cairo_destroy xlib-context) + ;; !! free xlib-context, surface + (xdestroywindow display window) + (xdestroywindow display signal-window) + (xclosedisplay display)))) + ;; initialize + (xsynchronize display 1) + (let* ((screen (xdefaultscreen display)) + (root (xdefaultrootwindow display)) + (visual (xdefaultvisual display screen)) + (whitepixel (xwhitepixel display screen))) + (with-slots (window signal-window thread wm-delete-window + pointer graphics-context xlib-context) + xlib-image-context + ;; create signal window and window + (setf window + (create-window display root width height 'inputoutput visual + whitepixel + (logior exposuremask + structurenotifymask) + t)) + (setf signal-window + (create-window display root 1 1 'inputonly visual + whitepixel 0 nil)) + ;; create graphics-context + (setf graphics-context + (xcreategc display window 0 (null-pointer))) + ;; set size hints on window (most window managers will respect this) + (set-window-size-hints display window width width height height) + ;; intern atom for window closing, set protocol on window + (setf wm-delete-window + (xinternatom display "WM_DELETE_WINDOW" 1)) + (with-foreign-object (prot 'atom) + (setf (mem-aref prot 'atom) wm-delete-window) + (xsetwmprotocols display window prot 1)) + ;; store name + (xstorename display window window-name) + ;; first we create an X11 surface and context on the window + (let ((xlib-surface (cairo_xlib_surface_create display window visual + width height))) + (setf xlib-context (cairo_create xlib-surface)) + (cairo_surface_destroy xlib-surface)) + ;; create cairo surface, then context, then set the + ;; surface as the source of the xlib-context + (let ((surface (cairo_image_surface_create :CAIRO_FORMAT_RGB24 + width height))) + (setf pointer (cairo_create surface)) + (cairo_set_source_surface xlib-context surface 0 0) + (cairo_surface_destroy surface)) + ;; map window + (xmapwindow display window) + ;; end of synchronizing + (xsynchronize display 0) + ;; start thread + (setf thread + (start-thread + #'event-loop + (format nil "thread for display ~a" display-name)))))) + ;; return context + xlib-image-context))) + +(defun send-message-to-signal-window (xlib-image-context message) + "Send the desired message to the context window." + (with-slots (pointer (display-pointer display) signal-window) xlib-image-context + (unless pointer + (warn "context is not active, can't send message to window") + (return-from send-message-to-signal-window)) + (with-foreign-object (xev :long 24) + (with-foreign-slots + ((type display window message-type format data0) + xev xclientmessageevent) + (setf type 33) ; clientnotify + (setf display display-pointer) + (setf window signal-window) + (setf message-type 0) + (setf format 32) + (setf data0 message) + (xsendevent display-pointer signal-window 0 0 xev)) + (xflush display-pointer)))) + +(defmethod destroy ((object xlib-image-context)) + (send-message-to-signal-window object +destroy-message+)) + +(defmethod sync ((object xlib-image-context)) + (when (zerop (sync-counter object)) + (send-message-to-signal-window object +refresh-message+))) + +(defmethod sync-lock ((object xlib-image-context)) + (incf (sync-counter object))) + +(defmethod sync-unlock ((object xlib-image-context)) + (with-slots (sync-counter) object + (when (plusp sync-counter) + (decf sync-counter))) + (sync object)) + +(defmethod sync-reset ((object xlib-image-context)) + (setf (sync-counter object) 0) + (sync object))

1 0

[cl-cairo2-cvs] r15 - tutorial
by tpapp＠common-lisp.net 20 Dec '07

20 Dec '07

Author: tpapp Date: Thu Dec 20 08:05:07 2007 New Revision: 15 Modified: cl-cairo2.asd context.lisp package.lisp tutorial/example.lisp xlib-context.lisp xlib.lisp Log: reorganization, bugfixes Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Dec 20 08:05:07 2007 @@ -13,9 +13,9 @@ (:file "text" :depends-on ("context")) (:file "transformations" :depends-on ("context")) (:file "xlib" :depends-on ("context") - :in-order-to ((load-op (feature :unix)) - (compile-op (feature :unix)))) - (:file "xlib-context" :depends-on ("xlib") - :in-order-to ((load-op (feature :unix)) - (compile-op (feature :unix))))) + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix)))) + (:file "xlib-image-context" :depends-on ("xlib") + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix))))) :depends-on (:cffi :cl-colors :cl-utilities)) Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Thu Dec 20 08:05:07 2007 @@ -172,6 +172,14 @@ (define-with-default-context-sync stroke) (define-with-default-context-sync stroke-preserve) +;;;; get-target + +(defun get-target (context) + "Obtain the target surface of a given context. Width and height +will be nil, as cairo can't provide that in general." + (new-surface-with-check (cairo_get_target (slot-value context 'pointer)) + nil nil)) + ;;;; ;;;; set colors using the cl-colors library ;;;; @@ -184,7 +192,7 @@ (defmethod set-source-color ((color rgba) &optional (context *context*)) (with-slots (red green blue alpha) color - (set-source-rgb red green blue alpha context))) + (set-source-rgba red green blue alpha context))) (defmethod set-source-color ((color hsv) &optional (context *context*)) (with-slots (red green blue) (hsv->rgb color) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Thu Dec 20 08:05:07 2007 @@ -8,10 +8,10 @@ ;; surface - get-width get-height destroy create-image-surface - image-surface-get-format image-surface-get-width - image-surface-get-height image-surface-create-from-png - surface-write-to-png with-png-file + get-width get-height destroy create-ps-surface create-pdf-surface + create-svg-surface create-image-surface image-surface-get-format + image-surface-get-width image-surface-get-height + image-surface-create-from-png surface-write-to-png with-png-file ;; context @@ -25,7 +25,7 @@ get-line-cap set-line-cap get-line-join set-line-join get-operator set-operator fill-path set-dash get-dash clip-extents fill-extents in-fill in-stoke create-ps-context create-pdf-context - create-svg-context + create-svg-context get-target ;; path @@ -49,6 +49,6 @@ trans-matrix-rotate trans-matrix-invert trans-matrix-multiply trans-matrix-distance transform-point - ;; xlib-context + ;; xlib-image-context - xlib-context xlib-display open-xlib-display create-xlib-context)) + xlib-image-context create-xlib-image-context)) Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Thu Dec 20 08:05:07 2007 @@ -14,9 +14,8 @@ (setf *context* (create-context *surface*)) (destroy *surface*) ;; clear the whole canvas with blue -(rectangle 0 0 200 100) (set-source-rgb 0.2 0.2 1) -(fill-path) +(paint) ;; draw a white diagonal line (move-to 200 0) (line-to 0 100) @@ -49,11 +48,7 @@ (defun mark-at (x y d red green blue) "Make a rectangle of size 2d around x y with the given colors, 50% alpha. Used for marking points." - (move-to (+ x d) (+ y d)) - (line-to (- x d) (+ y d)) - (line-to (- x d) (- y d)) - (line-to (+ x d) (- y d)) - (close-path) + (rectangle (- x d) (- y d) (* 2 d) (* 2 d)) (set-source-rgba red green blue 0.5) (fill-path)) @@ -71,9 +66,8 @@ (defparameter y 50) (setf *context* (create-ps-context "text.ps" width height)) ;; white background -(rectangle 0 0 width height) (set-source-rgb 1 1 1) -(fill-path) +(paint) ;; setup font (select-font-face "Arial" 'font-slant-normal 'font-weight-normal) (set-font-size size) Modified: xlib-context.lisp ============================================================================== --- xlib-context.lisp (original) +++ xlib-context.lisp Thu Dec 20 08:05:07 2007 @@ -51,31 +51,6 @@ 0 0 width height 0 0) (xsync display 1))) -(defun create-window (display parent width height class visual background-pixel - event-mask &optional (backing-store t)) - "Create an x11 window, placed at 0 0, with the given attributes. -For internal use in the cl-cairo2 package." - ;; call xcreatewindow with attributes - (with-foreign-object (attributes 'xsetwindowattributes) - (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask) - event-mask - (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel) - background-pixel - (foreign-slot-value attributes 'xsetwindowattributes 'backing-store) - (if backing-store 1 0)) - (xcreatewindow display parent 0 0 width height - 0 ; zero border width - 0 ; depth - copy from parent - (ecase class - (copyfromparent 0) - (inputoutput 1) - (inputonly 2)) ; class - visual - (if (eq class 'inputonly) - cweventmask - (logior cwbackpixel cwbackingstore cweventmask)) - attributes))) - (defun create-xlib-context (width height &key (display-name nil) (window-name (next-xlib-context-name))) @@ -101,7 +76,7 @@ (with-foreign-slots ((type window serial) xev xanyevent) ;; action based on event type (cond - ;; expose and configurenotify events + ;; expose events ((and (= type 12) (= window this-window)) (refresh-xlib-context xlib-context)) ;; clientnotify event @@ -121,14 +96,16 @@ ;; close down everything (with-slots (display pixmap window signal-window pointer) xlib-context + (xsynchronize display 1) (let ((saved-pointer pointer)) (setf pointer nil) ; invalidate first so it can't be used - (cairo_destroy saved-pointer)) +;; (cairo_destroy saved-pointer) + ) (xfreepixmap display pixmap) (xdestroywindow display window) - (xdestroywindow display signal-window) - (xclosedisplay display)))) - ;; initialize + (xdestroywindow display signal-window) + (xclosedisplay display)))) + ;; initialize (xsynchronize display 1) (let* ((screen (xdefaultscreen display)) (root (xdefaultrootwindow display)) @@ -201,7 +178,10 @@ (defun send-message-to-signal-window (xlib-context message) "Send the desired message to the context window." - (with-slots ((display-pointer display) signal-window) xlib-context + (with-slots (pointer (display-pointer display) signal-window) xlib-context + (unless pointer + (warn "context is not active, can't send message to window") + (return-from send-message-to-signal-window)) (with-foreign-object (xev :long 24) (with-foreign-slots ((type display window message-type format data0) @@ -213,8 +193,7 @@ (setf format 32) (setf data0 message) (xsendevent display-pointer signal-window 0 0 xev)) - (xflush display-pointer)))) - + (xsync display-pointer 1)))) (defmethod destroy ((object xlib-context)) (send-message-to-signal-window object +destroy-message+)) Modified: xlib.lisp ============================================================================== --- xlib.lisp (original) +++ xlib.lisp Thu Dec 20 08:05:07 2007 @@ -387,7 +387,102 @@ (first-event :int) (first-error :int)) +;; image manipulation + +(cffi:defcstruct XImage + (width :int) + (height :int) + (xoffset :int) + (format :int) + (data :pointer) + (byte-order :int) + (bitmap-unit :int) + (bitmap-bit-order :int) + (bitmap-pad :int) + (depth :int) + (bytes-per-line :int) + (bits-per-pixel :int) + (red-mask :unsigned-long) + (green-mask :unsigned-long) + (blue-mask :unsigned-long) + (obdata :pointer) + ;; funcs + (create-image :pointer) + (destroy-image :pointer) + (get-pixel :pointer) + (put-pixel :pointer) + (sub-image :pointer) + (add-pixel :pointer)) + +(defcfun ("XInitImage" xinitimage) :int + (ximage :pointer)) + +(defcfun ("XPutImage" xputimage) :int + (display display) + (drawable drawable) + (graphics-context graphics-context) + (ximage :pointer) + (src-x :int) + (src-y :int) + (dest-x :int) + (dest-y :int) + (width :unsigned-int) + (height :unsigned-int)) ;; call xinitthreads (xinitthreads) + + +;; various higher level functions + +(defun set-window-size-hints (display window + min-window-width max-window-width + min-window-height max-window-height) + ;; set size hints on window (most window managers will respect this) + (let ((hints (xallocsizehints))) + (with-foreign-slots ((flags x y min-width min-height + max-width max-height) + hints + xsizehints) + ;; we only set the first four values because old WM's might + ;; get confused if we don't, they should be ignored + (setf flags (logior pminsize pmaxsize) + x 0 + y 0 + ;; we don't need to set the following, but some WMs go + ;; crazy if we don't + (foreign-slot-value hints 'xsizehints 'width) max-window-width + (foreign-slot-value hints 'xsizehints 'height) max-window-height + ;; set desired min/max width/height + min-width min-window-width + max-width max-window-width + min-height min-window-height + max-height max-window-height) + (xsetwmnormalhints display window hints) + (xfree hints)))) + +(defun create-window (display parent width height class visual background-pixel + event-mask &optional (backing-store t)) + "Create an x11 window, placed at 0 0, with the given attributes. +For internal use in the cl-cairo2 package." + ;; call xcreatewindow with attributes + (with-foreign-object (attributes 'xsetwindowattributes) + (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask) + event-mask + (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel) + background-pixel + (foreign-slot-value attributes 'xsetwindowattributes 'backing-store) + (if backing-store 1 0)) + (xcreatewindow display parent 0 0 width height + 0 ; zero border width + 0 ; depth - copy from parent + (ecase class + (copyfromparent 0) + (inputoutput 1) + (inputonly 2)) ; class + visual + (if (eq class 'inputonly) + cweventmask + (logior cwbackpixel cwbackingstore cweventmask)) + attributes)))

1 0

[cl-cairo2-cvs] r14 - tutorial
by tpapp＠common-lisp.net 25 Aug '07

25 Aug '07

Author: tpapp Date: Sat Aug 25 08:34:48 2007 New Revision: 14 Modified: context.lisp package.lisp tutorial/x11-example.lisp Log: with-sync-lock added, x11-example.lisp fixed Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Sat Aug 25 08:34:48 2007 @@ -67,6 +67,15 @@ (defmethod sync-unlock ((object context))) (defmethod sync-reset ((object context))) +(defmacro with-sync-lock ((context) &body body) + "Lock sync for context for the duration of body. Protected against +nonlocal exits." + (once-only (context) + `(progn + (sync-lock ,context) + (unwind-protect (progn ,@body) + (sync-unlock ,context))))) + ;;;; ;;;; default context and convenience macros ;;;; Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Sat Aug 25 08:34:48 2007 @@ -15,8 +15,8 @@ ;; context - create-context sync sync-lock sync - sync-unlock sync-reset *context* save restore push-group pop-group + create-context sync sync-lock sync sync-unlock sync-reset + with-sync-lock *context* save restore push-group pop-group pop-group-to-source set-source-rgb set-source-rgba clip clip-preserve reset-clip copy-page show-page fill-preserve paint paint-with-alpha stroke stroke-preserve set-source-color Modified: tutorial/x11-example.lisp ============================================================================== --- tutorial/x11-example.lisp (original) +++ tutorial/x11-example.lisp Sat Aug 25 08:34:48 2007 @@ -7,11 +7,9 @@ (in-package :cairo-xlib-example) ;; open display -(defparameter *display* (open-x11-display ":0")) - (let ((width 400) (height 300)) - (setf *context* (create-x11-context width height *display*)) + (setf *context* (create-xlib-context width height :window-name "diagonal lines")) ;; clear the whole canvas with blue (rectangle 0 0 width height) (set-source-rgb 0.2 0.2 0.5) @@ -44,7 +42,7 @@ (defparameter width 800) (defparameter height 600) (defparameter max-angle 90d0) -(setf *context* (create-x11-context width height *display*)) +(setf *context* (create-xlib-context width height :window-name "rectangles")) ;; fill with white (rectangle 0 0 width height) (set-source-rgb 1 1 1) @@ -52,9 +50,9 @@ ;; draw the rectangles (dotimes (i 500) (let ((scaling (+ 5d0 (random 40d0)))) - (reset-matrix) ; reset matrix + (reset-trans-matrix) ; reset matrix (translate (random width) (random height)) ; move the origin - (scale scaling scaling) ; scale - (rotate (deg-to-rad (random max-angle))) ; rotate + (scale scaling scaling) ; scale + (rotate (deg-to-rad (random max-angle))) ; rotate (random-square (+ 0.1 (random 0.4))))) ;; need to close window manually

1 0

[cl-cairo2-cvs] r13 - tutorial
by tpapp＠common-lisp.net 22 Aug '07

22 Aug '07

Author: tpapp Date: Wed Aug 22 12:13:14 2007 New Revision: 13 Added: xlib-context.lisp Removed: x11-context.lisp Modified: cl-cairo2.asd context.lisp package.lisp surface.lisp transformations.lisp tutorial/tutorial.tex xlib.lisp Log: another major revamping of X11 code, also put exported symbols in package.lisp where they belong Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Wed Aug 22 12:13:14 2007 @@ -15,7 +15,7 @@ (:file "xlib" :depends-on ("context") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix)))) - (:file "x11-context" :depends-on ("xlib") + (:file "xlib-context" :depends-on ("xlib") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) :depends-on (:cffi :cl-colors :cl-utilities)) Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Wed Aug 22 12:13:14 2007 @@ -22,20 +22,24 @@ ;;;; context class ;;;; -(defclass context () ((pointer :initform nil))) - -(export - (defun create-context (surface) - (with-surface (surface pointer) - (let ((context (make-instance 'context))) - (setf (slot-value context 'pointer) (cairo_create pointer)) - ;; register finalizer -;; (let ((context-pointer (slot-value context 'pointer))) -;; (finalize context -;; #'(lambda () -;; (cairo_destroy context-pointer)))) - ;; return context - context)))) +(defclass context () + ((pointer :initform nil :initarg :pointer) + (width :initarg :width :reader get-width) + (height :initarg :height :reader get-height))) + +(defun create-context (surface) + (with-surface (surface pointer) + (let ((context (make-instance 'context + :pointer (cairo_create pointer) + :width (get-width surface) + :height (get-height surface)))) + ;; register finalizer + (let ((context-pointer (slot-value context 'pointer))) + (finalize context + #'(lambda () + (cairo_destroy context-pointer)))) + ;; return context + context))) (defmethod destroy ((object context)) (with-slots (pointer) object @@ -45,11 +49,23 @@ ;; deregister finalizer (cancel-finalization object)) -(defgeneric sync (object)) - -(defmethod sync ((object context)) - ;; most contexts don't need syncing - ) +(defgeneric sync (object) + (:documentation "Synchronize contents of the object with the + physical device if needed.")) +(defgeneric sync-lock (object) + (:documentation "Suspend syncing (ie sync will have no effect) until + sync-unlock is called. Calls to sync-lock nest.")) +(defgeneric sync-unlock (object) + (:documentation "Undo a call to sync-lock.")) +(defgeneric sync-reset (object) + (:documentation "Undo all calls to sync, ie object will be +synced (if necessary) no matter how many times sync was called before.")) + +;; most contexts don't need syncing +(defmethod sync ((object context))) +(defmethod sync-lock ((object context))) +(defmethod sync-unlock ((object context))) +(defmethod sync-reset ((object context))) ;;;; ;;;; default context and convenience macros @@ -74,28 +90,25 @@ "Define cairo function with *context* as its first argument and args as the rest, automatically mapping name to the appropriate cairo function." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context pointer) - (,(prepend-intern "cairo_" name) pointer ,@args))))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context pointer) + (,(prepend-intern "cairo_" name) pointer ,@args)))) (defmacro define-with-default-context-sync (name &rest args) "Define cairo function with *context* as its first argument and args as the rest, automatically mapping name to the appropriate cairo function. sync will be called after the operation." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context pointer) - (,(prepend-intern "cairo_" name) pointer ,@args)) - (sync context)))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context pointer) + (,(prepend-intern "cairo_" name) pointer ,@args)) + (sync context))) (defmacro define-flexible ((name pointer &rest args) &body body) "Like define-with-default context, but with arbitrary body, pointer will point to the context." - `(export - (defun ,name (,@args &optional (context *context*)) - (with-context (context ,pointer) - ,@body)))) + `(defun ,name (,@args &optional (context *context*)) + (with-context (context ,pointer) + ,@body))) (defmacro define-many-with-default-context (&body args) "Apply define-with-default context to a list. Each item is @@ -156,18 +169,15 @@ (defgeneric set-source-color (color &optional context)) -(defmethod set-source-color - ((color rgb) &optional (context *context*)) +(defmethod set-source-color ((color rgb) &optional (context *context*)) (with-slots (red green blue) color (set-source-rgb red green blue context))) -(defmethod set-source-color - ((color rgba) &optional (context *context*)) +(defmethod set-source-color ((color rgba) &optional (context *context*)) (with-slots (red green blue alpha) color (set-source-rgb red green blue alpha context))) -(defmethod set-source-color - ((color hsv) &optional (context *context*)) +(defmethod set-source-color ((color hsv) &optional (context *context*)) (with-slots (red green blue) (hsv->rgb color) (set-source-rgb red green blue context))) @@ -228,3 +238,11 @@ (define-flexible (in-stroke pointer x y) (not (zerop (cairo_in_stroke pointer x y)))) + +;;;; +;;;; convenience functions for creating contexts directly +;;;; + +(define-create-context ps) +(define-create-context pdf) +(define-create-context svg) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Wed Aug 22 12:13:14 2007 @@ -1,15 +1,54 @@ (defpackage :cl-cairo2 (:use :common-lisp :cffi :cl-colors :cl-utilities) - (:export ; !!! when the interface - ; stabilizes, remove export's - ; from all other places and - ; list them here - ;; utility functions - deg-to-rad + (:export + + ;; cairo + + destroy deg-to-rad + + ;; surface + + get-width get-height destroy create-image-surface + image-surface-get-format image-surface-get-width + image-surface-get-height image-surface-create-from-png + surface-write-to-png with-png-file + ;; context - *context* set-source-color + + create-context sync sync-lock sync + sync-unlock sync-reset *context* save restore push-group pop-group + pop-group-to-source set-source-rgb set-source-rgba clip + clip-preserve reset-clip copy-page show-page fill-preserve paint + paint-with-alpha stroke stroke-preserve set-source-color + get-line-width set-line-width get-miter-limit set-miter-limit + get-antialias set-antialias get-fill-rule set-fill-rule + get-line-cap set-line-cap get-line-join set-line-join get-operator + set-operator fill-path set-dash get-dash clip-extents fill-extents + in-fill in-stoke create-ps-context create-pdf-context + create-svg-context + + ;; path + + new-path new-sub-path close-path arc arc-negative curve-to line-to + move-to rectangle rel-move-to rel-curve-to rel-line-to text-path + get-current-point + + ;; text + + select-font-face set-font-size text-extents show-text + ;; transformations - make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy - trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p - ;; x11-context - x11-context x11-display open-x11-display create-x11-context)) + + translate scale rotate reset-trans-matrix make-trans-matrix + trans-matrix-xx trans-matrix-yx trans-matrix-xy trans-matrix-yy + trans-matrix-x0 trans-matrix-y0 trans-matrix-p transform + set-trans-matrix get-trans-matrix user-to-device + user-to-device-distance device-to-user device-to-user-distance + trans-matrix-init-translate trans-matrix-init-scale + trans-matrix-init-rotate trans-matrix-rotate trans-matrix-scale + trans-matrix-rotate trans-matrix-invert trans-matrix-multiply + trans-matrix-distance transform-point + + ;; xlib-context + + xlib-context xlib-display open-xlib-display create-xlib-context)) Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Wed Aug 22 12:13:14 2007 @@ -13,7 +13,10 @@ ;;;; class surface ;;;; -(defclass surface () ((pointer :initarg :pointer :initform nil))) +(defclass surface () + ((pointer :initarg :pointer :initform nil) + (width :initarg :width :reader get-width) + (height :initarg :height :reader get-height))) (defmacro with-alive-surface ((surface pointer) &body body) "Execute body with pointer pointing to cairo surface, if nil, @@ -39,9 +42,9 @@ (check-surface-pointer-status ,pointer ,@body))) -(defun new-surface-with-check (pointer) +(defun new-surface-with-check (pointer width height) "Check if the creation of new surface was successful, if so, return new class." - (let ((surface (make-instance 'surface))) + (let ((surface (make-instance 'surface :width width :height height))) (check-surface-pointer-status pointer (setf (slot-value surface 'pointer) pointer) ;; register finalizer @@ -62,97 +65,93 @@ ;;;; (defmacro define-create-surface (type) - `(export - (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface") - (filename width-in-points height-in-points) - (new-surface-with-check - (,(prepend-intern "cairo_" type :replace-dash nil - :suffix "_surface_create") - filename width-in-points height-in-points))))) + "Define the function create-<type>-surface." + `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface") + (filename width height) + (new-surface-with-check + (,(prepend-intern "cairo_" type :replace-dash nil + :suffix "_surface_create") + filename width height) + width height))) (defmacro define-create-context (type) - `(export - (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") - (filename width-in-points height-in-points) - "Create a surface, then a context for a file, then + `(defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") + (filename width height) + "Create a surface, then a context for a file, then destroy (dereference) the surface. The user only needs to destroy the context when done." - (let* ((surface (,(prepend-intern "create-" - type :replace-dash nil :suffix "-surface") - filename width-in-points height-in-points)) - (context (create-context surface))) - (destroy surface) - context)))) - + (let* ((surface (,(prepend-intern "create-" + type :replace-dash nil :suffix "-surface") + filename width height)) + (context (create-context surface))) + (destroy surface) + context))) ;;;; ;;;; PDF surface ;;;; (define-create-surface pdf) -(define-create-context pdf) ;;;; ;;;; PostScript surface ;;;; (define-create-surface ps) -(define-create-context ps) ;;;; ;;;; SVG surface ;;;; (define-create-surface svg) -(define-create-context svg) ;;;; ;;;; image surface ;;;; -(export - (defun create-image-surface (format width height) - (new-surface-with-check - (cairo_image_surface_create (lookup-enum format table-format) - width height)))) - -(export - (defun image-surface-get-format (surface) - (with-surface (surface pointer) - (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format)))) - -(export - (defun image-surface-get-width (surface) - (with-surface (surface pointer) - (cairo_image_surface_get_width pointer)))) - -(export - (defun image-surface-get-height (surface) - (with-surface (surface pointer) - (cairo_image_surface_get_height pointer)))) +(defun create-image-surface (format width height) + (new-surface-with-check + (cairo_image_surface_create (lookup-enum format table-format) + width height) + width height)) + +(defun image-surface-get-format (surface) + (with-surface (surface pointer) + (lookup-cairo-enum (cairo_image_surface_get_format pointer) table-format))) + +(defun image-surface-get-width (surface) + (with-surface (surface pointer) + (cairo_image_surface_get_width pointer))) + +(defun image-surface-get-height (surface) + (with-surface (surface pointer) + (cairo_image_surface_get_height pointer))) ;;;; ;;;; PNG surfaces ;;;; -(export - (defun image-surface-create-from-png (filename) - (new-surface-with-check (cairo_image_surface_create_from_png filename)))) - -(export - (defun surface-write-to-png (surface filename) - (with-surface (surface pointer) - (cairo_surface_write_to_png pointer filename)))) - -(export - (defmacro with-png-file ((filename format width height) &body body) - "Execute the body with context bound to a newly created png +(defun image-surface-create-from-png (filename) + (let ((surface + (new-surface-with-check (cairo_image_surface_create_from_png filename) + 0 0))) + (with-slots (width height) surface + (setf width (image-surface-get-width surface) + height (image-surface-get-height surface)) + surface))) + +(defun surface-write-to-png (surface filename) + (with-surface (surface pointer) + (cairo_surface_write_to_png pointer filename))) + +(defmacro with-png-file ((filename format width height) &body body) + "Execute the body with context bound to a newly created png file, and close it after executing body." - (let ((surface-name (gensym))) - `(let* ((,surface-name (create-image-surface ,format ,width ,height)) - (*context* (create-context ,surface-name))) - (progn - ,@body - (surface-write-to-png ,surface-name ,filename) - (destroy ,surface-name) - (destroy *context*)))))) + (let ((surface-name (gensym))) + `(let* ((,surface-name (create-image-surface ,format ,width ,height)) + (*context* (create-context ,surface-name))) + (progn + ,@body + (surface-write-to-png ,surface-name ,filename) + (destroy ,surface-name) + (destroy *context*))))) Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Wed Aug 22 12:13:14 2007 @@ -131,12 +131,11 @@ (defmacro define-matrix-init (name &rest args) "Define a matrix initializer function with args, which returns the new matrix." - `(export - (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args - (with-trans-matrix-out matrix-pointer - (,(prepend-intern "cairo_matrix_init_" name) - matrix-pointer - ,@args))))) + `(defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args + (with-trans-matrix-out matrix-pointer + (,(prepend-intern "cairo_matrix_init_" name) + matrix-pointer + ,@args)))) (define-matrix-init translate tx ty) (define-matrix-init scale sx sy) @@ -157,23 +156,20 @@ (define-matrix-transformation rotate radians) (define-matrix-transformation invert) -(export - (defun trans-matrix-multiply (a b) - (with-trans-matrix-in a a-pointer - (with-trans-matrix-in b b-pointer - (with-trans-matrix-out result-pointer - (cairo_matrix_multiply result-pointer - a-pointer - b-pointer)))))) - -(export - (defun transform-distance (matrix x y) - (with-trans-matrix-in matrix matrix-pointer - (with-x-y - (cairo_matrix_transform_distance matrix-pointer xp yp))))) - -(export - (defun transform-point (matrix x y) - (with-trans-matrix-in matrix matrix-pointer - (with-x-y - (cairo_matrix_transform_point matrix-pointer xp yp))))) +(defun trans-matrix-multiply (a b) + (with-trans-matrix-in a a-pointer + (with-trans-matrix-in b b-pointer + (with-trans-matrix-out result-pointer + (cairo_matrix_multiply result-pointer + a-pointer + b-pointer))))) + +(defun transform-distance (matrix x y) + (with-trans-matrix-in matrix matrix-pointer + (with-x-y + (cairo_matrix_transform_distance matrix-pointer xp yp)))) + +(defun transform-point (matrix x y) + (with-trans-matrix-in matrix matrix-pointer + (with-x-y + (cairo_matrix_transform_point matrix-pointer xp yp)))) Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Wed Aug 22 12:13:14 2007 @@ -128,14 +128,15 @@ CLOS wrappers, and can be closed (\emph{destroyed}) with \lstinline!destroy!. -When the context is created from a surface, the reference count of the -latter is incremented. You can immediately destroy the surface: it -will not be destroyed (ie the file will not be closed) until you -destroy the context.\footnote{The file will also be closed if the - wrapper object is garbage collected. However, you should not rely - on this, as calling the garbage collector is not portable.} The -following code draws a white diagonal line on a blue background, using -a Postscript file -- the result is shown in Figure~\ref{fig:example}. +When the context is created from a surface, the reference count (in +the internals of Cairo) of the latter is incremented. You can +immediately destroy the surface: it will not be destroyed (ie the file +will not be closed) until you destroy the context.\footnote{The file + will also be closed if the wrapper object is garbage collected. + However, you should not rely on this, as calling the garbage + collector is not portable.} The following code draws a white +diagonal line on a blue background, using a Postscript file -- the +result is shown in Figure~\ref{fig:example}. \lstinputlisting[firstline=13,lastline=27]{example.lisp} @@ -153,6 +154,10 @@ \begin{lstlisting} (setf *context* (create-ps-context "example.ps" 200 100)) \end{lstlisting} +Unlike the original Cairo API, surfaces and contexts in +\lstinline!cl-cairo2! remember their width and height. Use the +generic functions \lstinline!get-width! and \lstinline!get-height! to +extract these. When you want to write the output into a bitmap file (for example, in PNG format), you first need to create an \emph{image surface}, then @@ -230,7 +235,7 @@ written to PNG files) are supported. Drawing in X11 windows is implemented using the -\lstinline!x11-context! class --- see Section~\ref{sec:x11-context} +\lstinline!x11-context! class --- see Section~\ref{sec:xlib-context} for more information. \subsection{Contexts} @@ -334,45 +339,50 @@ with \lstinline!trans-matrix-!, and other a few other functions have been renamed to avoid conflicts with linear algebra packages. -\subsection{X11 Contexts} -\label{sec:x11-context} +\subsection{Xlib Contexts} +\label{sec:xlib-context} -The x11 context is not part of cairo -- it is a bit of glue code that +The xlib context is not part of cairo -- it is a bit of glue code that uses cairo's X11 surface on a pixmap, and displays this pixmap when needed (when X11 asks for the window contents to be redrawn or when cairo draws on the pixmap). -In order to open an \lstinline!x11-context!, first you need to open an -\lstinline!x11-display!, for example, -\begin{lstlisting} -(defparameter *display* (open-x11-display ":0")) -\end{lstlisting} -opens a display on the local host. Each display runs an event loop in -a separate thread, and you can open several display and several -windows on each simultaneously. The X11 event loop runs in a separate -thread, so you need a Lisp implementation that supports threads. You -can close displays with \lstinline!destroy!, all open windows will be -closed and the contexts mapping into these windows will be destroyed -(drawing on them will be an invalid operation). - -For cl-cairo2, each window maps to a context. The surface is not +In cl-cairo2, each window maps to a context. The surface is not exposed to the user, who is only allowed to see the context. This -makes memory management and proper cleanup easier. - -You can create Xlib contexts with +makes memory management and proper cleanup easier. For example, you +can create an \lstinline!xlib-context! with \begin{lstlisting} - (create-x11-context width height display) +(setf *context* (create-xlib-context 500 400 + :display-name "localhost:0" + :window-name "my pretty drawing")) \end{lstlisting} -When \lstinline!destroy!ed, the window is closed. This works the -other way too: when the window is closed, the context is destroyed. -The windows are double-buffered using a pixmap on the X11 server, -therefore redrawing exposed windows is fast. However, this +If you give \lstinline!nil! for \lstinline!display-name!, Xlib fill +probably figure out a reasonable default, usually from your +\verb!$DISPLAY! environment variable. + +The X11 event loop runs in a separate thread, so you need a Lisp +implementation that supports threads. + +When the context \lstinline!destroy!ed, the window is closed. This +works the other way too: when the window is closed, the context is +destroyed. The windows are double-buffered using a pixmap on the X11 +server, therefore redrawing exposed windows is fast. However, this implementation precludes the resizing of the window. Example code can be found in \verb!tutorial/x11-example.lisp!. The current implementation is not optimized for speed (the whole window is -redrawn all the time) but it is fast enough for me. If you need speed -improvements desperately, please contact the author. +redrawn all the time) but it is fast enough. If you draw a lot of +objects at the same time, it is suggested that you suspend +synchronizing with the X-window server using + \lstinline!(sync-lock context)!. + When you are done, you can call \lstinline!(sync-unlock context)!, which will automatically sync the buffer and the window. +You can nest calls to \lstinline!sync-lock! and +\lstinline!sync-unlock!, and if you want to restore syncing +unconditionally, use \lstinline!sync-reset!, which also performs +syncing too. These are generic functions which do nothing for other +contexts. + + \subsection{To Do} \label{sec:todo} Added: xlib-context.lisp ============================================================================== --- (empty file) +++ xlib-context.lisp Wed Aug 22 12:13:14 2007 @@ -0,0 +1,238 @@ +(in-package :cl-cairo2) + +;; constants for communicating with the signal window +(defconstant +destroy-message+ 4072) ; just some random constant +(defconstant +refresh-message+ 2495) ; ditto + +(defvar *xlib-context-count* 0 "window counter for autogenerating names") + +(defun next-xlib-context-name () + "Return an autogenerated window name using *xlib-context-count*." + (format nil "cl-cairo2 ~a" (incf *xlib-context-count*))) + +;; code to make threads, please extend with your own Lisp if needed +;; testing is welcome, I only tested cmucl and sbcl +(defun start-thread (function name) + #+allegro (mp:process-run-function name function) + #+armedbear (ext:make-thread function :name name) + #+cmu (mp:make-process function :name name) + #+lispworks (mp:process-run-function name nil function) + #+openmcl (ccl:process-run-function name function) + #+sbcl (sb-thread:make-thread function :name name)) + +;; we create this definition manually, SWIG just messes things up +(defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t + (display display) + (drawable drawable) + (visual visual) + (width :int) + (height :int)) + +;; The class for an x11 context. Each context has a separate display +;; queue, window and an event loop in a separate thread. Once the +;; event loop is started, communication with the thread is done via +;; X11 ClientNotify events (see wacky constants above). + +(defclass xlib-context (context) + ((display :initarg :display) + (wm-delete-window) + (window) + (signal-window) + (pixmap) + (graphics-context) + (thread) + (sync-counter :initform 0 :accessor sync-counter))) + +(defun refresh-xlib-context (xlib-context) + "Copy the contents of the pixmap to the window. This function is +meant for internal use in the cl-cairo2 package." + (with-slots (display width height window pixmap graphics-context) xlib-context + (xcopyarea display pixmap window graphics-context + 0 0 width height 0 0) + (xsync display 1))) + +(defun create-window (display parent width height class visual background-pixel + event-mask &optional (backing-store t)) + "Create an x11 window, placed at 0 0, with the given attributes. +For internal use in the cl-cairo2 package." + ;; call xcreatewindow with attributes + (with-foreign-object (attributes 'xsetwindowattributes) + (setf (foreign-slot-value attributes 'xsetwindowattributes 'event-mask) + event-mask + (foreign-slot-value attributes 'xsetwindowattributes 'background-pixel) + background-pixel + (foreign-slot-value attributes 'xsetwindowattributes 'backing-store) + (if backing-store 1 0)) + (xcreatewindow display parent 0 0 width height + 0 ; zero border width + 0 ; depth - copy from parent + (ecase class + (copyfromparent 0) + (inputoutput 1) + (inputonly 2)) ; class + visual + (if (eq class 'inputonly) + cweventmask + (logior cwbackpixel cwbackingstore cweventmask)) + attributes))) + +(defun create-xlib-context (width height &key + (display-name nil) + (window-name (next-xlib-context-name))) + (let ((display (xopendisplay (if display-name display-name (null-pointer))))) + (when (null-pointer-p display) + (error "couldn't open display ~a" display-name)) + (let ((xlib-context (make-instance 'xlib-context + :display display + :width width + :height height))) + (flet ((event-loop () + (with-slots (display (this-window window) signal-window + pixmap + wm-delete-window graphics-context) + xlib-context + (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1))) + (with-foreign-object (xev :long 24) + (do ((got-close-signal nil)) + (got-close-signal) + ;; get next event + (xnextevent display xev) + ;; decipher structure, at least partially + (with-foreign-slots ((type window serial) xev xanyevent) + ;; action based on event type + (cond + ;; expose and configurenotify events + ((and (= type 12) (= window this-window)) + (refresh-xlib-context xlib-context)) + ;; clientnotify event + ((= type 33) + (with-foreign-slots ((message-type data0) xev + xclientmessageevent) + (cond + ((or (and (= window signal-window) + (= data0 +destroy-message+)) + (and (= window this-window) + (= message-type wm-protocols) + (= data0 wm-delete-window))) + (setf got-close-signal t)) + ((and (= window signal-window) + (= data0 +refresh-message+)) + (refresh-xlib-context xlib-context))))))))))) + ;; close down everything + (with-slots (display pixmap window signal-window pointer) + xlib-context + (let ((saved-pointer pointer)) + (setf pointer nil) ; invalidate first so it can't be used + (cairo_destroy saved-pointer)) + (xfreepixmap display pixmap) + (xdestroywindow display window) + (xdestroywindow display signal-window) + (xclosedisplay display)))) + ;; initialize + (xsynchronize display 1) + (let* ((screen (xdefaultscreen display)) + (root (xdefaultrootwindow display)) + (visual (xdefaultvisual display screen)) + (depth (xdefaultdepth display screen)) + (whitepixel (xwhitepixel display screen))) + (with-slots (window pixmap signal-window thread wm-delete-window + pointer graphics-context) xlib-context + ;; create signal window and window + (setf window + (create-window display root width height 'inputoutput visual + whitepixel + (logior exposuremask + structurenotifymask) + t)) + (setf signal-window + (create-window display root 1 1 'inputonly visual + whitepixel 0 nil)) + ;; create pixmap + (setf pixmap + (xcreatepixmap display window width height depth)) + ;; create graphics-context + (setf graphics-context + (xcreategc display pixmap 0 (null-pointer))) + ;; set size hints on window (most window managers will respect this) + (let ((hints (xallocsizehints))) + (with-foreign-slots ((flags x y min-width min-height + max-width max-height) + hints + xsizehints) + ;; we only set the first four values because old WM's might + ;; get confused if we don't, they should be ignored + (setf flags (logior pminsize pmaxsize) + x 0 + y 0 + (foreign-slot-value hints 'xsizehints 'width) width + (foreign-slot-value hints 'xsizehints 'height) height + min-width width + max-width width + min-height height + max-height height) + (xsetwmnormalhints display window hints) + (xfree hints))) + ;; intern atom for window closing, set protocol on window + (setf wm-delete-window + (xinternatom display "WM_DELETE_WINDOW" 1)) + (with-foreign-object (prot 'atom) + (setf (mem-aref prot 'atom) wm-delete-window) + (xsetwmprotocols display window prot 1)) + ;; store name + (xstorename display window window-name) + ;; create cairo context + (let ((surface (cairo_xlib_surface_create display pixmap visual + width height))) + (setf pointer (cairo_create surface)) + ;; !!! error checking + (cairo_surface_destroy surface)) + ;; map window + (xmapwindow display window) + ;; end of synchronizing + (xsynchronize display 0) + ;; start thread + (setf thread + (start-thread + #'event-loop + (format nil "thread for display ~a" display-name)))))) + ;; return context + xlib-context))) + + +(defun send-message-to-signal-window (xlib-context message) + "Send the desired message to the context window." + (with-slots ((display-pointer display) signal-window) xlib-context + (with-foreign-object (xev :long 24) + (with-foreign-slots + ((type display window message-type format data0) + xev xclientmessageevent) + (setf type 33) ; clientnotify + (setf display display-pointer) + (setf window signal-window) + (setf message-type 0) + (setf format 32) + (setf data0 message) + (xsendevent display-pointer signal-window 0 0 xev)) + (xflush display-pointer)))) + + +(defmethod destroy ((object xlib-context)) + (send-message-to-signal-window object +destroy-message+)) + +(defmethod sync ((object xlib-context)) + (when (zerop (sync-counter object)) + (send-message-to-signal-window object +refresh-message+))) + +(defmethod sync-lock ((object xlib-context)) + (incf (sync-counter object))) + +(defmethod sync-unlock ((object xlib-context)) + (with-slots (sync-counter) object + (when (plusp sync-counter) + (decf sync-counter))) + (sync object)) + +(defmethod sync-reset ((object xlib-context)) + (setf (sync-counter object) 0) + (sync object)) + Modified: xlib.lisp ============================================================================== --- xlib.lisp (original) +++ xlib.lisp Wed Aug 22 12:13:14 2007 @@ -13,6 +13,8 @@ (defctype drawable xid) (defctype window xid) (defctype pixmap xid) +(defctype cursor xid) +(defctype colormap xid) (defctype graphics-context xid) (defctype visual :pointer) (defctype atom :unsigned-long) @@ -62,7 +64,6 @@ ownergrabbuttonmask 24) - ;;;; error code handling (defmacro check-status (call) "Check the return calue of call, if nonzero, display an error message." @@ -139,6 +140,60 @@ (border :unsigned-long) (background :unsigned-long)) +(defcfun ("XCreateWindow" xcreatewindow) window + (display display) + (parent window) + (x :int) + (y :int) + (width :unsigned-int) + (height :unsigned-int) + (border-width :unsigned-int) + (depth :int) + (class :unsigned-int) + (visual visual) + (valuemask :unsigned-long) + (attributes :pointer)) + +(defcstruct xsetwindowattributes + (background-pixmap pixmap) + (background-pixel :unsigned-long) + (border-pixmap pixmap) + (border-pixel :unsigned-long) + (bit-gravity :int) + (win-gravity :int) + (backing-store :int) + (backing-planes :unsigned-long) + (backing-pixel :unsigned-long) + (save-under bool) + (event-mask :long) + (do-not-propagate_mask :long) + (override-redirect bool) + (colormap colormap) + (cursor cursor)) + +(define-bitmask-constants + CWBackPixmap 0 + CWBackPixel 1 + CWBorderPixmap 2 + CWBorderPixel 3 + CWBitGravity 4 + CWWinGravity 5 + CWBackingStore 6 + CWBackingPlanes 7 + CWBackingPixel 8 + CWOverrideRedirect 9 + CWSaveUnder 10 + CWEventMask 11 + CWDontPropagate 12 + CWColormap 13 + CWCursor 14) + +(defcfun ("XChangeWindowAttributes" xchangewindowattributes) :int + (display display) + (window window) + (valuemask :unsigned-long) + (attributes :pointer)) + (defcfun ("XDestroyWindow" xdestroywindow) :int (display display) (window window)) @@ -170,12 +225,23 @@ (height :unsigned-int) (destination-x :int) (destination-y :int)) - +(defcfun ("XSetGraphicsExposures" xsetgraphicsexposures) :int + (display display) + (graphics-context graphics-context) + (graphics-exposures bool)) + + ;; synchronization & threads (defcfun ("XInitThreads" xinitthreads) :int) +(defcfun ("XLockDisplay" xlockdisplay) :int + (display display)) + +(defcfun ("XUnlockDisplay" xunlockdisplay) :int + (display display)) + (defcfun ("XSynchronize" xsynchronize) :int (display display) (onoff :int)) @@ -243,6 +309,14 @@ ;; we only use first field, union of message data is not included (data0 :unsigned-long)) +(defcstruct xvisibilityevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (window window) + (state :int)) + (defcfun ("XNextEvent" xnextevent) :int (display display) (event-return :pointer))

1 0

[cl-cairo2-cvs] r12 - tutorial
by tpapp＠common-lisp.net 14 Aug '07

14 Aug '07

Author: tpapp Date: Tue Aug 14 03:53:12 2007 New Revision: 12 Modified: transformations.lisp tutorial/ (props changed) tutorial/example.lisp tutorial/tutorial.tex Log: minor fixes in transformations code Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Tue Aug 14 03:53:12 2007 @@ -5,13 +5,16 @@ ;;;; cairo-matrix-init is not defined, as we have a structure in lisp ;;;; with an appropriate constructor ;;;; -;;;; cairo_identity_matrix is reset-matrix +;;;; cairo_identity_matrix is reset-trans-matrix ;;;; ;;;; functions that manipulate transformation matrices have ;;;; trans-matrix instead of matrix in their name ;;;; ;;;; cairo_matrix_transform_distance and cairo_matrix_transform_point ;;;; are simply transform-distance and transform-point +;;;; +;;;; cairo_matrix_init is not defined, make-trans-matrix will give +;;;; you an identity matrix ;;;; ;;;; simple functions @@ -22,7 +25,7 @@ (scale sx sy) (rotate angle)) -(define-flexible (reset-matrix pointer) +(define-flexible (reset-trans-matrix pointer) (cairo_identity_matrix pointer)) @@ -30,7 +33,13 @@ ;;;; transition matrix structure and helper functions/macros ;;;; -(defstruct trans-matrix xx yx xy yy x0 y0) +(defstruct trans-matrix + (xx 1d0 :type double-float) + (yx 0d0 :type double-float) + (xy 0d0 :type double-float) + (yy 1d0 :type double-float) + (x0 0d0 :type double-float) + (y0 0d0 :type double-float)) (defun trans-matrix-copy-in (pointer matrix) "Copy matrix to a memory location." @@ -108,7 +117,7 @@ (define-flexible (get-trans-matrix pointer) (with-trans-matrix-out matrix-pointer - (cairo_set_matrix pointer matrix-pointer))) + (cairo_get_matrix pointer matrix-pointer))) (define-with-x-y user-to-device) (define-with-x-y user-to-device-distance) @@ -129,7 +138,6 @@ matrix-pointer ,@args))))) -(define-matrix-init identity) (define-matrix-init translate tx ty) (define-matrix-init scale sx sy) (define-matrix-init rotate radians) Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Tue Aug 14 03:53:12 2007 @@ -167,7 +167,7 @@ ;; draw the hearts (dotimes (i 200) (let ((scaling (+ 5d0 (random 40d0)))) - (reset-matrix) ; reset matrix + (reset-trans-matrix) ; reset matrix (translate (random width) (random height)) ; move the origin (scale scaling scaling) ; scale (rotate (deg-to-rad (- (random (* 2 max-angle)) max-angle 180))) ; rotate Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Tue Aug 14 03:53:12 2007 @@ -189,7 +189,8 @@ \verb!cairo_fill! (would conflict with \lstinline!cl:fill!) & \lstinline!fill-path! \\ \verb!cairo_identity_matrix! (would - conflict with matrix algebra packages)& \lstinline!reset-matrix! \\ + conflict with matrix algebra packages)& \lstinline!reset-trans-matrix! \\ + \verb!cairo_matrix_init_identity! & use \lstinline!(make-trans-matrix)!\\ \verb!cairo_matrix_transform_distance! & \lstinline!transform-distance!\\ \verb!cairo_matrix_transform_point! & @@ -320,10 +321,12 @@ cl-cairo2 defines the structure \lstinline!trans-matrix! with the slots \lstinline!xx!, \lstinline!yx!, \lstinline!xy!, \lstinline!yy!, -\lstinline!x0!, \lstinline!y0!. All the functions that use -transformation matrices use this structure. Consequently, -\verb!cairo_matrix_init! has no corresponding function in cl-cairo2: -you can construct a translation matrix using +\lstinline!x0!, \lstinline!y0!. The defaults for these slots give you +the identity matrix. + +All the functions that use transformation matrices use this structure. +Consequently, \verb!cairo_matrix_init! has no corresponding function +in cl-cairo2: you can construct a translation matrix using \lstinline!make-trans-matrix!. Some functions are renamed, see Table~\ref{tab:naming}. Generally,

1 0

[cl-cairo2-cvs] r11 - cffi tutorial
by tpapp＠common-lisp.net 13 Aug '07

13 Aug '07

Author: tpapp Date: Mon Aug 13 10:30:44 2007 New Revision: 11 Added: tutorial/x11-example.lisp x11-context.lisp xlib.lisp Removed: README.xlib-context cffi/ tutorial/xlib-example.lisp xlib-context.lisp Modified: cl-cairo2-swig.lisp cl-cairo2.asd cl-cairo2.i context.lisp package.lisp path.lisp surface.lisp transformations.lisp tutorial/tutorial.tex Log: minor bugfixes, complete reworking of x11 support, support for cl-colors Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Mon Aug 13 10:30:44 2007 @@ -1279,50 +1279,4 @@ (cffi:defcfun ("cairo_svg_version_to_string" cairo_svg_version_to_string) :string (version cairo_svg_version_t)) -(cffi:defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) :pointer - (dpy :pointer) - (drawable :pointer) - (visual :pointer) - (width :int) - (height :int)) - -(cffi:defcfun ("cairo_xlib_surface_create_for_bitmap" cairo_xlib_surface_create_for_bitmap) :pointer - (dpy :pointer) - (bitmap :pointer) - (screen :pointer) - (width :int) - (height :int)) - -(cffi:defcfun ("cairo_xlib_surface_set_size" cairo_xlib_surface_set_size) :void - (surface :pointer) - (width :int) - (height :int)) - -(cffi:defcfun ("cairo_xlib_surface_set_drawable" cairo_xlib_surface_set_drawable) :void - (surface :pointer) - (drawable :pointer) - (width :int) - (height :int)) - -(cffi:defcfun ("cairo_xlib_surface_get_display" cairo_xlib_surface_get_display) :pointer - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_drawable" cairo_xlib_surface_get_drawable) :pointer - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_screen" cairo_xlib_surface_get_screen) :pointer - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_visual" cairo_xlib_surface_get_visual) :pointer - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_depth" cairo_xlib_surface_get_depth) :int - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_width" cairo_xlib_surface_get_width) :int - (surface :pointer)) - -(cffi:defcfun ("cairo_xlib_surface_get_height" cairo_xlib_surface_get_height) :int - (surface :pointer)) - Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Mon Aug 13 10:30:44 2007 @@ -1,6 +1,6 @@ (defsystem cl-cairo2 :description "Cairo 1.4 bindings" - :version "0.2.3" + :version "0.3" :author "Tamas K Papp" :license "GPL" :components ((:file "package") @@ -12,7 +12,10 @@ (:file "path" :depends-on ("context")) (:file "text" :depends-on ("context")) (:file "transformations" :depends-on ("context")) - (:file "xlib-context" :depends-on ("context") - :in-order-to ((load-op (feature :unix)) - (compile-op (feature :unix))))) - :depends-on (:cffi :cl-colors)) + (:file "xlib" :depends-on ("context") + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix)))) + (:file "x11-context" :depends-on ("xlib") + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix))))) + :depends-on (:cffi :cl-colors :cl-utilities)) Modified: cl-cairo2.i ============================================================================== --- cl-cairo2.i (original) +++ cl-cairo2.i Mon Aug 13 10:30:44 2007 @@ -44,6 +44,5 @@ %include /usr/include/cairo/cairo-xlib-xrender.h %include /usr/include/cairo/cairo-pdf.h %include /usr/include/cairo/cairo-svg.h -%include /usr/include/cairo/cairo-xlib.h Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Mon Aug 13 10:30:44 2007 @@ -30,10 +30,10 @@ (let ((context (make-instance 'context))) (setf (slot-value context 'pointer) (cairo_create pointer)) ;; register finalizer - (let ((context-pointer (slot-value context 'pointer))) - (finalize context - #'(lambda () - (cairo_destroy context-pointer)))) +;; (let ((context-pointer (slot-value context 'pointer))) +;; (finalize context +;; #'(lambda () +;; (cairo_destroy context-pointer)))) ;; return context context)))) @@ -97,7 +97,7 @@ (with-context (context ,pointer) ,@body)))) -(defmacro define-many-with-default-context (&rest args) +(defmacro define-many-with-default-context (&body args) "Apply define-with-default context to a list. Each item is itself a list, first element gives the function name, the rest the arguments." @@ -131,8 +131,8 @@ ;;;; (define-many-with-default-context - (save) - (restore) + (save) + (restore) (push-group) (pop-group) (pop-group-to-source) @@ -151,28 +151,27 @@ (define-with-default-context-sync stroke-preserve) ;;;; -;;;; set colors using the color library +;;;; set colors using the cl-colors library ;;;; + (defgeneric set-source-color (color &optional context)) (defmethod set-source-color - ((color rgb-color) &optional (context *context*)) - (set-source-rgb - (rgb-color-red color) - (rgb-color-green color) - (rgb-color-blue color) - context)) + ((color rgb) &optional (context *context*)) + (with-slots (red green blue) color + (set-source-rgb red green blue context))) (defmethod set-source-color - ((color rgba-color) &optional (context *context*)) - (set-source-rgba - (rgba-color-red color) - (rgba-color-green color) - (rgba-color-blue color) - (rgba-color-alpha color) - context)) - + ((color rgba) &optional (context *context*)) + (with-slots (red green blue alpha) color + (set-source-rgb red green blue alpha context))) + +(defmethod set-source-color + ((color hsv) &optional (context *context*)) + (with-slots (red green blue) (hsv->rgb color) + (set-source-rgb red green blue context))) + ;;;; ;;;; functions that get/set a property without any conversion ;;;; Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Mon Aug 13 10:30:44 2007 @@ -1,5 +1,5 @@ (defpackage :cl-cairo2 - (:use :common-lisp :cffi :cl-colors) + (:use :common-lisp :cffi :cl-colors :cl-utilities) (:export ; !!! when the interface ; stabilizes, remove export's ; from all other places and @@ -10,4 +10,6 @@ *context* set-source-color ;; transformations make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy - trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p)) + trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p + ;; x11-context + x11-context x11-display open-x11-display create-x11-context)) Modified: path.lisp ============================================================================== --- path.lisp (original) +++ path.lisp Mon Aug 13 10:30:44 2007 @@ -1,8 +1,8 @@ (in-package :cl-cairo2) (define-many-with-default-context - (new-path) - (new-sub-path) + (new-path) + (new-sub-path) (close-path) (arc xc yc radius angle1 angle2) (arc-negative xc yc radius angle1 angle2) Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Mon Aug 13 10:30:44 2007 @@ -45,7 +45,7 @@ (check-surface-pointer-status pointer (setf (slot-value surface 'pointer) pointer) ;; register finalizer - (finalize surface #'(lambda () (cairo_surface_destroy pointer))) +;; (finalize surface #'(lambda () (cairo_surface_destroy pointer))) ;; return surface surface))) Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Mon Aug 13 10:30:44 2007 @@ -18,8 +18,8 @@ ;;;; (define-many-with-default-context - (translate tx ty) - (scale sx sy) + (translate tx ty) + (scale sx sy) (rotate angle)) (define-flexible (reset-matrix pointer) @@ -82,8 +82,8 @@ and copies x and y in/out before/after (respectively) the execution of body." `(with-foreign-objects ((xp :double) (yp :double)) - (setf (mem-ref xp :double) x - (mem-ref yp :double) y) + (setf (mem-ref xp :double) (coerce x 'double-float) + (mem-ref yp :double) (coerce y 'double-float)) ,@body (values (mem-ref xp :double) (mem-ref yp :double)))) @@ -92,7 +92,7 @@ returns the latter two." `(define-flexible (,name pointer x y) (with-x-y - (,(prepend-intern "cairo_" name) pointer xp yp)))) + (,(prepend-intern "cairo_" name) pointer xp yp)))) ;;;; ;;;; transformation and conversion functions Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Mon Aug 13 10:30:44 2007 @@ -229,7 +229,7 @@ written to PNG files) are supported. Drawing in X11 windows is implemented using the -\lstinline!xlib-context! class --- see Section~\ref{sec:xlib-context} +\lstinline!x11-context! class --- see Section~\ref{sec:x11-context} for more information. \subsection{Contexts} @@ -331,32 +331,42 @@ with \lstinline!trans-matrix-!, and other a few other functions have been renamed to avoid conflicts with linear algebra packages. -\subsection{Xlib Contexts} -\label{sec:xlib-context} +\subsection{X11 Contexts} +\label{sec:x11-context} -The xlib context is not part of cairo -- it is a bit of glue code that +The x11 context is not part of cairo -- it is a bit of glue code that uses cairo's X11 surface on a pixmap, and displays this pixmap when needed (when X11 asks for the window contents to be redrawn or when -cairo draws on the pixmap). For the latter, it uses the XDamage -extension. +cairo draws on the pixmap). -The X11 event loop runs in a separate thread, so you need a Lisp -implementation that supports threads. The surface is not exposed to -the user, who is only allowed to see the context. This makes memory -management and proper cleanup easier. - -\textbf{Important:} before proceeding, make sure that you read -\verb!README.xlib-context! on how to install the shared library with -the necessary code. +In order to open an \lstinline!x11-context!, first you need to open an +\lstinline!x11-display!, for example, +\begin{lstlisting} +(defparameter *display* (open-x11-display ":0")) +\end{lstlisting} +opens a display on the local host. Each display runs an event loop in +a separate thread, and you can open several display and several +windows on each simultaneously. The X11 event loop runs in a separate +thread, so you need a Lisp implementation that supports threads. You +can close displays with \lstinline!destroy!, all open windows will be +closed and the contexts mapping into these windows will be destroyed +(drawing on them will be an invalid operation). + +For cl-cairo2, each window maps to a context. The surface is not +exposed to the user, who is only allowed to see the context. This +makes memory management and proper cleanup easier. You can create Xlib contexts with \begin{lstlisting} - (create-xlib-context width height) + (create-x11-context width height display) \end{lstlisting} When \lstinline!destroy!ed, the window is closed. This works the other way too: when the window is closed, the context is destroyed. +The windows are double-buffered using a pixmap on the X11 server, +therefore redrawing exposed windows is fast. However, this +implementation precludes the resizing of the window. -Example code can be found in \verb!tutorial/xlib-example.lisp!. The +Example code can be found in \verb!tutorial/x11-example.lisp!. The current implementation is not optimized for speed (the whole window is redrawn all the time) but it is fast enough for me. If you need speed improvements desperately, please contact the author. Added: tutorial/x11-example.lisp ============================================================================== --- (empty file) +++ tutorial/x11-example.lisp Mon Aug 13 10:30:44 2007 @@ -0,0 +1,60 @@ +(asdf:operate 'asdf:load-op :cl-cairo2) + +;;;; Make a test package +(defpackage :cairo-xlib-example + (:use :common-lisp :cl-cairo2)) + +(in-package :cairo-xlib-example) + +;; open display +(defparameter *display* (open-x11-display ":0")) + +(let ((width 400) + (height 300)) + (setf *context* (create-x11-context width height *display*)) + ;; clear the whole canvas with blue + (rectangle 0 0 width height) + (set-source-rgb 0.2 0.2 0.5) + (fill-path) + ;; draw a white diagonal line + (move-to width 0) + (line-to 0 height) + (set-source-rgb 1 1 1) + (set-line-width 5) + (stroke) + ;; draw a green diagonal line + (move-to 0 0) + (line-to width height) + (set-source-rgb 0 1 0) + (set-line-width 5) + (stroke)) +;; need to close window manually + + +(defun random-square (alpha) + "Draw a blue rectangle with fixed size and the given transparency alpha." + (move-to 1 1) + (line-to -1 1) + (line-to -1 -1) + (line-to 1 -1) + (close-path) + (set-source-rgba 0 0 1 alpha) + (fill-path)) + +(defparameter width 800) +(defparameter height 600) +(defparameter max-angle 90d0) +(setf *context* (create-x11-context width height *display*)) +;; fill with white +(rectangle 0 0 width height) +(set-source-rgb 1 1 1) +(fill-path) +;; draw the rectangles +(dotimes (i 500) + (let ((scaling (+ 5d0 (random 40d0)))) + (reset-matrix) ; reset matrix + (translate (random width) (random height)) ; move the origin + (scale scaling scaling) ; scale + (rotate (deg-to-rad (random max-angle))) ; rotate + (random-square (+ 0.1 (random 0.4))))) +;; need to close window manually Added: x11-context.lisp ============================================================================== --- (empty file) +++ x11-context.lisp Mon Aug 13 10:30:44 2007 @@ -0,0 +1,272 @@ +(in-package :cl-cairo2) + + +(defconstant x11-display-destroy-message-type 29653) +(defconstant x11-display-destroy-data0 17875817) + +(defvar *x11-context-count* 0 "window counter for autogenerating names") + +(defun next-x11-context-name () + "Return an autogenerated window name using *x11-context-count*." + (format nil "cl-cairo2 ~a" (incf *x11-context-count*))) + +;; x11-display + +(defclass x11-context (context) + ((width :initarg :width) + (height :initarg :height) + (window :initarg :window :accessor window) + (pixmap :initarg :pixmap) + (graphics-context :initarg :graphics-context) + (x11-display + :initarg :x11-display + :documentation "refers back to the context's X11 display"))) + +(defclass x11-display () + ((display + :initform nil + :documentation "pointer to an xlib display, if nil, the display is +closed and all other fields should be ignored") + (screen + :documentation "screen number") + (root) + (visual) + (depth) + (whitepixel) + (wm-delete-window + :documentation "atom for the WM_DELETE_WINDOW event") + (signal-window + :documentation "window used for sending signals to the event loop, unmapped") + (thread + :documentation "the thread id") + (x11-contexts + :initform nil + :documentation "a list of X11 contexts on this display"))) + + +;; code to make threads, please extend with your own Lisp if needed +;; testing is welcome, I only tested cmucl and sbcl +(defun start-thread (function name) + #+allegro (mp:process-run-function name function) + #+armedbear (ext:make-thread function :name name) + #+cmu (mp:make-process function :name name) + #+lispworks (mp:process-run-function name nil function) + #+openmcl (ccl:process-run-function name function) + #+sbcl (sb-thread:make-thread function :name name)) + +;; we create this definition manually, SWIG just messes things up +(defcfun ("cairo_xlib_surface_create" cairo_xlib_surface_create) cairo_surface_t + (display display) + (drawable drawable) + (visual visual) + (width :int) + (height :int)) + +;;;; +;;;; The important code starts here. The event model is the +;;;; following: we open an x11-display, which is attached to an Xlib +;;;; display, and has a list of x11-contexts, which is initially +;;;; empty. An event loop is started in a separate thread: each time +;;;; an event arrives, it is matched to one of the windows and is +;;;; acted upon. +;;;; +;;;; Each x11-context has a window where its contents appear. +;;;; +;;;; The window signal-window serves a special purpose. It remains +;;;; unmapped, but allows us to send events (eg requests to terminate) +;;;; to the event loop even if there are no x11-contexts. + +(defun refresh-x11-context (display x11-context) + "Copy the contents of the pixmap to the window." + (with-slots (width height window pixmap graphics-context) x11-context + (xcopyarea display pixmap window graphics-context + 0 0 width height 0 0) + (xsync display 1))) + + +(defun open-x11-display (display-name) + "Open an X11 display, get the constants and start an event loop." + (let ((x11-display (make-instance 'x11-display))) + (with-slots (display screen root visual depth whitepixel wm-delete-window + signal-window thread x11-contexts) x11-display + ;; open display + (setf display (xopendisplay display-name)) + (when (null-pointer-p display) + (error "couldn't open display ~a" display-name)) + ;; get defaults + (setf screen (xdefaultscreen display) + root (xdefaultrootwindow display)) + (setf visual (xdefaultvisual display screen) + depth (xdefaultdepth display screen) + whitepixel (xwhitepixel display screen)) + ;; get WM_DELETE_WINDOW atom + (setf wm-delete-window + (xinternatom display "WM_DELETE_WINDOW" 1)) + ;; create signal-window + (setf signal-window + ;; window is given strictly positive size + (xcreatesimplewindow display root 0 0 1 1 0 + whitepixel whitepixel)) + (xselectinput display signal-window 0) + ;; start threads + (setf thread + (start-thread + (lambda () + (let ((wm-protocols (xinternatom display "WM_PROTOCOLS" 1))) + (with-foreign-object (xev :long 24) + (do ((got-close-signal nil)) + (got-close-signal) + ;; get next event + (xnextevent display xev) + ;; decipher structure, at least partially + (with-foreign-slots ((type window) xev xanyevent) + (let ((x11-context (find window x11-contexts :key #'window))) + ;; action based on event type + (cond + ;; expose event + ((and (= type 12) x11-context) + (refresh-x11-context display x11-context)) + ; clientnotify event + ((= type 33) + (with-foreign-slots ((message-type data0) xev + xclientmessageevent) + ;; WM_DELETE_WINDOW + (when (and x11-context + (= message-type wm-protocols) + (= data0 wm-delete-window)) + (destroy x11-context)) + ;; signal to the x11-display + (when (= window signal-window) + (xclosedisplay display) + (setf display nil) + (setf got-close-signal t))))))))))) + (format nil "thread for display ~a" display-name))) + ;; return x11-display + x11-display))) + + +(defun close-x11-context (x11-context) + "Close related window and do some cleanup, except removal from + x11-contexts of the x11-display. This function is meant to be used + internally and is not exported." + (with-slots (x11-display window pixmap pointer) x11-context + (with-slots (x11-contexts display) x11-display + ;; we will sync all operations during destruction of the window + (xsynchronize display 1) + ;; destroy cairo context + (let ((saved-pointer pointer)) + (setf pointer nil) ; invalidate first so it can't be used + (cairo_destroy saved-pointer)) + ;; free pixmap + (xfreepixmap display pixmap) + (setf pixmap nil) + ;; destroy window + (xdestroywindow display window) + (setf window nil) + ;; set x11-display of context to nil + (setf x11-display nil)))) + + +(defmethod destroy ((object x11-context)) + (with-slots (x11-contexts) (slot-value object 'x11-display) + ;; close + (close-x11-context object) + ;; remove from the list of windows + (setf x11-contexts (remove object x11-contexts)))) + + +(defun create-x11-context (width height x11-display + &optional (x11-context-name (next-x11-context-name))) + "Create an x11-context (a window with a context that belongs to it) +with given dimensions and optional name. If the name is not given, it +will be autogenerated." + (assert (typep x11-display 'x11-display)) + (let ((x11-context (make-instance 'x11-context + :width width + :height height + :x11-display x11-display))) + (with-slots (pointer width height window pixmap graphics-context) x11-context + (with-slots (display screen root visual depth whitepixel wm-delete-window + x11-contexts) x11-display + ;; add window to list + (push x11-context x11-contexts) + ;; we will sync all operations during setup of the window + (xsynchronize display 1) + ;; create window and pixmap + (setf window + (xcreatesimplewindow display root 0 0 width height + 0 whitepixel whitepixel)) + (setf pixmap + (xcreatepixmap display window width height depth)) + ;; create graphics context + (setf graphics-context + (xcreategc display pixmap 0 (null-pointer))) + ;; window name + (xstorename display window x11-context-name) + ;; size hints (most window managers will respect this) + (let ((hints (xallocsizehints))) + (with-foreign-slots ((flags x y min-width min-height + max-width max-height) + hints + xsizehints) + ;; we only set the first four values because old WM's might + ;; get confused if we don't, they should be ignored + (setf flags (logior pminsize pmaxsize) + x 0 + y 0 + (foreign-slot-value hints 'xsizehints 'width) width + (foreign-slot-value hints 'xsizehints 'height) height + min-width width + max-width width + min-height height + max-height height) + (xsetwmnormalhints display window hints))) + ;; select input + (xselectinput display window (logior exposuremask structurenotifymask)) + ;; handle window closing + (with-foreign-object (prot 'atom) + (setf (mem-aref prot 'atom) wm-delete-window) + (xsetwmprotocols display window prot 1)) + ;; map window + (xmapwindow display window) + ;; create xlib surface and context, destroy surface (not needed any more) + (let ((surface (cairo_xlib_surface_create display pixmap visual + width height))) + (setf pointer (cairo_create surface)) + ;; !!! error checking + (cairo_surface_destroy surface)) + ;; turn of synchronization + (xsynchronize display 0) + ;; return x11-context + x11-context)))) + + +(defmethod sync ((object x11-context)) + (with-slots (x11-display) object + (with-slots (display) x11-display + (refresh-x11-context display object)))) + + +(defmethod destroy ((object x11-display)) + "Close X11 display, destroying all the contexts if necessary." + (with-slots ((display-pointer display) signal-window x11-contexts) + object + (unless display-pointer + (error "This display is not open.")) + (when x11-contexts + (dolist (x11-context x11-contexts) + (close-x11-context x11-context) + (setf x11-contexts nil))) + (with-foreign-object (xev :long 24) + (with-foreign-slots + ((type display window message-type format data0) + xev xclientmessageevent) + (setf type 33) ; clientnotify + (setf display display-pointer) + (setf window signal-window) + (setf message-type 0) + (setf format 32) + (setf data0 0) + (xsendevent display signal-window 0 0 xev)) + (xflush display-pointer)))) + Added: xlib.lisp ============================================================================== --- (empty file) +++ xlib.lisp Mon Aug 13 10:30:44 2007 @@ -0,0 +1,319 @@ +(in-package :cl-cairo2) + +;;;; +;;;; a limited interface to certain Xlib functions +;;;; + +(load-foreign-library "libX11.so") + +;;;; types + +(defctype display :pointer) +(defctype xid :unsigned-long) ; X Id type +(defctype drawable xid) +(defctype window xid) +(defctype pixmap xid) +(defctype graphics-context xid) +(defctype visual :pointer) +(defctype atom :unsigned-long) +(defctype bool :int) + +;; constants + +(defmacro define-bitmask-constants (&body name-power-pairs) + "Define a list of constants from name-value pairs, raising 2 to +the power value." + (labels ((dbc (pairs) + (case (length pairs) + (0 nil) + (1 (error "no power after ~a" (car name-power-pairs))) + (t (destructuring-bind (name power &rest rest) pairs + `((defconstant ,name (expt 2 ,power)) + ,@(dbc rest))))))) + `(progn + ,@(dbc name-power-pairs)))) + +(defconstant noeventmask 0) +(define-bitmask-constants + keypressmask 0 + keyreleasemask 1 + buttonpressmask 2 + buttonreleasemask 3 + enterwindowmask 4 + leavewindowmask 5 + pointermotionmask 6 + pointermotionhintmask 7 + button1motionmask 8 + button2motionmask 9 + button3motionmask 10 + button4motionmask 11 + button5motionmask 12 + buttonmotionmask 13 + keymapstatemask 14 + exposuremask 15 + visibilitychangemask 16 + structurenotifymask 17 + resizeredirectmask 18 + substructurenotifymask 19 + substructureredirectmask 20 + focuschangemask 21 + propertychangemask 23 + colormapchangemask 23 + ownergrabbuttonmask 24) + + + +;;;; error code handling +(defmacro check-status (call) + "Check the return calue of call, if nonzero, display an error message." + (with-unique-names (status) + `(let ((,status ,call)) + (if (zerop ,status) + (values) + (error "operations ~a returned status (error) ~a" ',call ,status))))) + +;;;; display operations + +(defcfun ("XOpenDisplay" xopendisplay) display + (display-name :string)) + +(defcfun ("XCloseDisplay" xclosedisplay) :int + (display display)) + + +;;;; defaults for the X11 display & screen + +(defcfun ("XDefaultDepth" xdefaultdepth) :int + (display display) + (screen-number :int)) + +(defcfun ("XDefaultRootWindow" xdefaultrootwindow) window + (display display)) + +(defcfun ("XDefaultScreen" xdefaultscreen) :int + (display display)) + +(defcfun ("XDefaultVisual" xdefaultvisual) visual + (display display) + (screen-number :int)) + +(defcfun ("XBlackPixel" xblackpixel) :unsigned-long + (display display) + (screen-number :int)) + +(defcfun ("XWhitePixel" xwhitepixel) :unsigned-long + (display display) + (screen-number :int)) + + +;;;; graphics contexts + +(defcfun ("XDefaultGC" xdefaultgc) graphics-context + (display display) + (screen-number :int)) + +(defcfun ("XCreateGC" xcreategc) graphics-context + (display display) + (drawable drawable) + (valuemask :unsigned-long) + (xgcvalues :pointer)) + +(defcfun ("XFreeGC" xfreegc) :int + (display display) + (graphics-context graphics-context)) + +;;;; window and pixmap management + +(defcfun ("XMapWindow" xmapwindow) :int + (display display) + (window window)) + +(defcfun ("XCreateSimpleWindow" xcreatesimplewindow) window + (display display) + (parent window) + (x :int) + (y :int) + (width :unsigned-int) + (height :unsigned-int) + (border-width :unsigned-int) + (border :unsigned-long) + (background :unsigned-long)) + +(defcfun ("XDestroyWindow" xdestroywindow) :int + (display display) + (window window)) + +(defcfun ("XCreatePixmap" xcreatepixmap) pixmap + (display display) + (drawable drawable) + (width :unsigned-int) + (height :unsigned-int) + (depth :unsigned-int)) + +(defcfun ("XFreePixmap" xfreepixmap) :int + (display display) + (pixmap pixmap)) + +(defcfun ("XSelectInput" xselectinput) :int + (display display) + (window window) + (event-mask :long)) + +(defcfun ("XCopyArea" xcopyarea) :int + (display display) + (source drawable) + (destination drawable) + (graphics-context graphics-context) + (source-x :int) + (source-y :int) + (width :unsigned-int) + (height :unsigned-int) + (destination-x :int) + (destination-y :int)) + + +;; synchronization & threads + +(defcfun ("XInitThreads" xinitthreads) :int) + +(defcfun ("XSynchronize" xsynchronize) :int + (display display) + (onoff :int)) + +(defcfun ("XFlush" xflush) :int + (display display)) + +(defcfun ("XSync" xsync) :int + (display display) + (discard :int)) + +;; atoms & protocols + +(defcfun ("XInternAtom" xinternatom) atom + (display display) + (atom-name :string) + (only-if-exists :int)) + +(defcfun ("XSetWMProtocols" xsetwmprotocols) :int + (display display) + (window window) + (protocols :pointer) + (count :int)) + + +;; events + +(defcstruct xanyevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (window window)) + +(defcstruct xexposeevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (drawable drawable) + (x :int) + (y :int) + (width :int) + (height :int) + (count :int) + (major-code :int) + (minor-code :int)) + +(defcstruct xdestroywindowevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (event window) + (window window)) + +(defcstruct xclientmessageevent + (type :int) + (serial :unsigned-long) + (send-event bool) + (display display) + (window window) + (message-type atom) + (format :int) + ;; we only use first field, union of message data is not included + (data0 :unsigned-long)) + +(defcfun ("XNextEvent" xnextevent) :int + (display display) + (event-return :pointer)) + +(defcfun ("XSendEvent" xsendevent) :int + (display display) + (window window) + (propagate bool) + (event-mask :long) + (xevent :pointer)) + +;; hints & misc + +(defcstruct xsizehints + (flags :long) ; marks which fields in this structure are defined + (x :int) ; Obsolete + (y :int) ; Obsolete + (width :int) ; Obsolete + (height :int) ; Obsolete + (min-width :int) + (min-height :int) + (max-width :int) + (max-height :int) + (min-aspect-x :int) ; numerator + (min-aspect-y :int) ; denominator + (max-aspect-x :int) ; numerator + (max-aspect-y :int) ; denominator + (base-width :int) + (base_height :int) + (win_gravity :int)) + +(define-bitmask-constants + USPosition 0 + USSize 1 + PPosition 2 + PSize 3 + PMinSize 4 + PMaxSize 5 + PResizeInc 6 + PAspect 7 + PBaseSize 8 + PWinGravity 9) + +(defcfun ("XAllocSizeHints" xallocsizehints) :pointer) + +(defcfun ("XSetWMNormalHints" xsetwmnormalhints) :void + (display display) + (window window) + (hints :pointer)) + +(defcfun ("XStoreName" xstorename) :int + (display display) + (window window) + (window-name :string)) + +(defcfun ("XFree" xfree) :int + (data :pointer)) + + +;; extensions + +(defcfun ("XAddExtension" xaddextension) :pointer + (display display)) + +(defcstruct xextcodes + (extensions :int) + (major-opcode :int) + (first-event :int) + (first-error :int)) + + +;; call xinitthreads + +(xinitthreads)

1 0

[cl-cairo2-cvs] r10 - tutorial
by tpapp＠common-lisp.net 26 Jul '07

26 Jul '07

Author: tpapp Date: Thu Jul 26 10:52:20 2007 New Revision: 10 Modified: cl-cairo2-swig.lisp cl-cairo2.asd cl-cairo2.i context.lisp package.lisp tutorial/tutorial.tex Log: interface using cl-colors added Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Thu Jul 26 10:52:20 2007 @@ -2,10 +2,10 @@ (in-package :cl-cairo2) (defctype my-double :double) -(defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) - `(coerce ,value 'double-float)) -;; (defmethod translate-to-foreign (value (type my-double)) -;; (coerce value 'double-float)) +;; (defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) +;; `(coerce ,value 'double-float)) +(defmethod translate-to-foreign (value (type (eql 'my-double))) + (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Jul 26 10:52:20 2007 @@ -1,6 +1,6 @@ (defsystem cl-cairo2 :description "Cairo 1.4 bindings" - :version "0.2.2" + :version "0.2.3" :author "Tamas K Papp" :license "GPL" :components ((:file "package") @@ -15,4 +15,4 @@ (:file "xlib-context" :depends-on ("context") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) - :depends-on (:cffi)) + :depends-on (:cffi :cl-colors)) Modified: cl-cairo2.i ============================================================================== --- cl-cairo2.i (original) +++ cl-cairo2.i Thu Jul 26 10:52:20 2007 @@ -10,10 +10,10 @@ (in-package :cl-cairo2) (defctype my-double :double) -(defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) - `(coerce ,value 'double-float)) -;; (defmethod translate-to-foreign (value (type my-double)) -;; (coerce value 'double-float)) +;; (defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) +;; `(coerce ,value 'double-float)) +(defmethod translate-to-foreign (value (type (eql 'my-double))) + (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Thu Jul 26 10:52:20 2007 @@ -150,6 +150,29 @@ (define-with-default-context-sync stroke) (define-with-default-context-sync stroke-preserve) +;;;; +;;;; set colors using the color library +;;;; +(defgeneric set-source-color (color &optional context)) + +(defmethod set-source-color + ((color rgb-color) &optional (context *context*)) + (set-source-rgb + (rgb-color-red color) + (rgb-color-green color) + (rgb-color-blue color) + context)) + +(defmethod set-source-color + ((color rgba-color) &optional (context *context*)) + (set-source-rgba + (rgba-color-red color) + (rgba-color-green color) + (rgba-color-blue color) + (rgba-color-alpha color) + context)) + + ;;;; ;;;; functions that get/set a property without any conversion ;;;; Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Thu Jul 26 10:52:20 2007 @@ -1,5 +1,5 @@ (defpackage :cl-cairo2 - (:use :common-lisp :cffi) + (:use :common-lisp :cffi :cl-colors) (:export ; !!! when the interface ; stabilizes, remove export's ; from all other places and @@ -7,7 +7,7 @@ ;; utility functions deg-to-rad ;; context - *context* + *context* set-source-color ;; transformations make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p)) Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Thu Jul 26 10:52:20 2007 @@ -261,6 +261,14 @@ I doubt that Lisp users need \lstinline!get/set-user-data! or \lstinline!get-reference-count!. Let me know if you do. +Since version 0.2.3, you can use colors from +\href{http://www.cliki.net/cl-colors}{cl-colors} with the generic +function \lstinline!set-source-color!, for example, +\begin{lstlisting} + (set-source-color +darkolivegreen+) +\end{lstlisting} + + \subsection{Paths} \label{sec:paths}

1 0

[cl-cairo2-cvs] r9 -
by tpapp＠common-lisp.net 21 Jul '07

21 Jul '07

Author: tpapp Date: Sat Jul 21 09:44:55 2007 New Revision: 9 Modified: cl-cairo2.asd Log: version number changed Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Sat Jul 21 09:44:55 2007 @@ -1,6 +1,6 @@ (defsystem cl-cairo2 :description "Cairo 1.4 bindings" - :version "0.2.1" + :version "0.2.2" :author "Tamas K Papp" :license "GPL" :components ((:file "package")

1 0

[cl-cairo2-cvs] r8 - tutorial
by tpapp＠common-lisp.net 21 Jul '07

21 Jul '07

Author: tpapp Date: Sat Jul 21 09:41:55 2007 New Revision: 8 Modified: context.lisp surface.lisp tables.lisp tutorial/example.lisp tutorial/tutorial.tex Log: changed to longer property names to avoid name clashes Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Sat Jul 21 09:41:55 2007 @@ -66,7 +66,7 @@ (multiple-value-prog1 (progn ,@body) (let ((,status (lookup-cairo-enum (cairo_status ,pointer-name) table-status))) - (unless (eq ,status 'success) + (unless (eq ,status 'status-success) (warn "function returned with status ~a." ,status)))) (warn "context is not alive"))))) Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Sat Jul 21 09:41:55 2007 @@ -30,7 +30,7 @@ `(multiple-value-prog1 (progn ,@body) (let ((,status (lookup-cairo-enum (cairo_surface_status ,pointer) table-status))) - (unless (eq ,status 'success) + (unless (eq ,status 'status-success) (warn "function returned with status ~a." ,status)))))) (defmacro with-surface ((surface pointer) &body body) Modified: tables.lisp ============================================================================== --- tables.lisp (original) +++ tables.lisp Sat Jul 21 09:41:55 2007 @@ -9,99 +9,99 @@ (export (cdr i))))) (exporting-table table-format - '((:CAIRO_FORMAT_ARGB32 . argb32) - (:CAIRO_FORMAT_RGB24 . rgb24) - (:CAIRO_FORMAT_A8 . a8) - (:CAIRO_FORMAT_A1 . a1))) + '((:CAIRO_FORMAT_ARGB32 . format-argb32) + (:CAIRO_FORMAT_RGB24 . format-rgb24) + (:CAIRO_FORMAT_A8 . format-a8) + (:CAIRO_FORMAT_A1 . format-a1))) (exporting-table table-antialias - '((:CAIRO_ANTIALIAS_DEFAULT . default) - (:CAIRO_ANTIALIAS_NONE . none) - (:CAIRO_ANTIALIAS_GRAY . gray) - (:CAIRO_ANTIALIAS_SUBPIXEL . subpixel))) + '((:CAIRO_ANTIALIAS_DEFAULT . antialias-default) + (:CAIRO_ANTIALIAS_NONE . antialias-none) + (:CAIRO_ANTIALIAS_GRAY . antialias-gray) + (:CAIRO_ANTIALIAS_SUBPIXEL . antialias-subpixel))) (exporting-table table-fill-rule - '((:CAIRO_FILL_RULE_WINDING . winding) - (:CAIRO_FILL_RULE_EVEN_ODD . odd))) + '((:CAIRO_FILL_RULE_WINDING . fill-rule-winding) + (:CAIRO_FILL_RULE_EVEN_ODD . fill-rule-odd))) (exporting-table table-line-cap - '((:CAIRO_LINE_CAP_BUTT . butt) - (:CAIRO_LINE_CAP_ROUND . round) - (:CAIRO_LINE_CAP_SQUARE . square))) + '((:CAIRO_LINE_CAP_BUTT . line-cap-butt) + (:CAIRO_LINE_CAP_ROUND . line-cap-round) + (:CAIRO_LINE_CAP_SQUARE . line-cap-square))) (exporting-table table-line-join - '((:CAIRO_LINE_JOIN_MITER . miter) - (:CAIRO_LINE_JOIN_ROUND . round) - (:CAIRO_LINE_JOIN_BEVEL . bevel))) + '((:CAIRO_LINE_JOIN_MITER . line-join-miter) + (:CAIRO_LINE_JOIN_ROUND . line-join-round) + (:CAIRO_LINE_JOIN_BEVEL . line-join-bevel))) (exporting-table table-operator - '((:CAIRO_OPERATOR_CLEAR . clear) - (:CAIRO_OPERATOR_SOURCE . source) - (:CAIRO_OPERATOR_OVER . over) - (:CAIRO_OPERATOR_IN . in) - (:CAIRO_OPERATOR_OUT . out) - (:CAIRO_OPERATOR_ATOP . atop) - (:CAIRO_OPERATOR_DEST . dest) - (:CAIRO_OPERATOR_DEST_OVER . dest-over) - (:CAIRO_OPERATOR_DEST_IN . dest-in) - (:CAIRO_OPERATOR_DEST_OUT . dest-out) - (:CAIRO_OPERATOR_DEST_ATOP . dest-atop) - (:CAIRO_OPERATOR_XOR . xor) - (:CAIRO_OPERATOR_ADD . add) - (:CAIRO_OPERATOR_SATURATE . saturate))) + '((:CAIRO_OPERATOR_CLEAR . operator-clear) + (:CAIRO_OPERATOR_SOURCE . operator-source) + (:CAIRO_OPERATOR_OVER . operator-over) + (:CAIRO_OPERATOR_IN . operator-in) + (:CAIRO_OPERATOR_OUT . operator-out) + (:CAIRO_OPERATOR_ATOP . operator-atop) + (:CAIRO_OPERATOR_DEST . operator-dest) + (:CAIRO_OPERATOR_DEST_OVER . operator-dest-over) + (:CAIRO_OPERATOR_DEST_IN . operator-dest-in) + (:CAIRO_OPERATOR_DEST_OUT . operator-dest-out) + (:CAIRO_OPERATOR_DEST_ATOP . operator-dest-atop) + (:CAIRO_OPERATOR_XOR . operator-xor) + (:CAIRO_OPERATOR_ADD . operator-add) + (:CAIRO_OPERATOR_SATURATE . operator-saturate))) (exporting-table table-font-slant - '((:CAIRO_FONT_SLANT_NORMAL . normal) - (:CAIRO_FONT_SLANT_ITALIC . italic) - (:CAIRO_FONT_SLANT_OBLIQUE . oblique))) + '((:CAIRO_FONT_SLANT_NORMAL . font-slant-normal) + (:CAIRO_FONT_SLANT_ITALIC . font-slant-italic) + (:CAIRO_FONT_SLANT_OBLIQUE . font-slant-oblique))) (exporting-table table-font-weight - '((:CAIRO_FONT_WEIGHT_NORMAL . normal) - (:CAIRO_FONT_WEIGHT_BOLD . bold))) + '((:CAIRO_FONT_WEIGHT_NORMAL . font-weight-normal) + (:CAIRO_FONT_WEIGHT_BOLD . font-weight-bold))) (exporting-table table-subpixel-order - '((:CAIRO_SUBPIXEL_ORDER_DEFAULT . default) - (:CAIRO_SUBPIXEL_ORDER_RGB . rgb) - (:CAIRO_SUBPIXEL_ORDER_BGR .bgr) - (:CAIRO_SUBPIXEL_ORDER_VRGB . vrgb) - (:CAIRO_SUBPIXEL_ORDER_VBGR . vbgr))) + '((:CAIRO_SUBPIXEL_ORDER_DEFAULT . subpixel-order-default) + (:CAIRO_SUBPIXEL_ORDER_RGB . subpixel-order-rgb) + (:CAIRO_SUBPIXEL_ORDER_BGR . subpixel-order-bgr) + (:CAIRO_SUBPIXEL_ORDER_VRGB . subpixel-order-vrgb) + (:CAIRO_SUBPIXEL_ORDER_VBGR . subpixel-order-vbgr))) (exporting-table table-hint-style - '((:CAIRO_HINT_STYLE_DEFAULT . default) - (:CAIRO_HINT_STYLE_NONE . none) - (:CAIRO_HINT_STYLE_SLIGHT . slight) - (:CAIRO_HINT_STYLE_MEDIUM . medium) - (:CAIRO_HINT_STYLE_FULL . full))) + '((:CAIRO_HINT_STYLE_DEFAULT . hint-style-default) + (:CAIRO_HINT_STYLE_NONE . hint-style-none) + (:CAIRO_HINT_STYLE_SLIGHT . hint-style-slight) + (:CAIRO_HINT_STYLE_MEDIUM . hint-style-medium) + (:CAIRO_HINT_STYLE_FULL . hint-style-full))) (exporting-table table-hint-metrics - '((:CAIRO_HINT_METRICS_DEFAULT . default) - (:CAIRO_HINT_METRICS_OFF . off) - (:CAIRO_HINT_METRICS_ON . on))) + '((:CAIRO_HINT_METRICS_DEFAULT . hint-metrics-default) + (:CAIRO_HINT_METRICS_OFF . hint-metrics-off) + (:CAIRO_HINT_METRICS_ON . hint-metrics-on))) (exporting-table table-status - '((:CAIRO_STATUS_SUCCESS . success) - (:CAIRO_STATUS_NO_MEMORY . no-memory) - (:CAIRO_STATUS_INVALID_RESTORE . invalid-restore) - (:CAIRO_STATUS_INVALID_POP_GROUP . invalid-pop-group) - (:CAIRO_STATUS_NO_CURRENT_POINT . no-current-point) - (:CAIRO_STATUS_INVALID_MATRIX . invalid-matrix) - (:CAIRO_STATUS_INVALID_STATUS . invalid-status) - (:CAIRO_STATUS_NULL_POINTER . null-pointer) - (:CAIRO_STATUS_INVALID_STRING . invalid-string) - (:CAIRO_STATUS_INVALID_PATH_DATA . invalid-path-data) - (:CAIRO_STATUS_READ_ERROR . read-error) - (:CAIRO_STATUS_WRITE_ERROR . write-error) - (:CAIRO_STATUS_SURFACE_FINISHED . surface-finished) - (:CAIRO_STATUS_SURFACE_TYPE_MISMATCH . surface-type-mismatch) - (:CAIRO_STATUS_PATTERN_TYPE_MISMATCH . pattern-type-mismatch) - (:CAIRO_STATUS_INVALID_CONTENT . invalid-content) - (:CAIRO_STATUS_INVALID_FORMAT . invalid-format) - (:CAIRO_STATUS_INVALID_VISUAL . invalid-visual) - (:CAIRO_STATUS_FILE_NOT_FOUND . file-not-found) - (:CAIRO_STATUS_INVALID_DASH . invalid-dash) - (:CAIRO_STATUS_INVALID_DSC_COMMENT . invalid-dsc-comment) - (:CAIRO_STATUS_INVALID_INDEX . invalid-index) - (:CAIRO_STATUS_CLIP_NOT_REPRESENTABLE . clip-not-representable))) + '((:CAIRO_STATUS_SUCCESS . status-success) + (:CAIRO_STATUS_NO_MEMORY . status-no-memory) + (:CAIRO_STATUS_INVALID_RESTORE . status-invalid-restore) + (:CAIRO_STATUS_INVALID_POP_GROUP . status-invalid-pop-group) + (:CAIRO_STATUS_NO_CURRENT_POINT . status-no-current-point) + (:CAIRO_STATUS_INVALID_MATRIX . status-invalid-matrix) + (:CAIRO_STATUS_INVALID_STATUS . status-invalid-status) + (:CAIRO_STATUS_NULL_POINTER . status-null-pointer) + (:CAIRO_STATUS_INVALID_STRING . status-invalid-string) + (:CAIRO_STATUS_INVALID_PATH_DATA . status-invalid-path-data) + (:CAIRO_STATUS_READ_ERROR . status-read-error) + (:CAIRO_STATUS_WRITE_ERROR . status-write-error) + (:CAIRO_STATUS_SURFACE_FINISHED . status-surface-finished) + (:CAIRO_STATUS_SURFACE_TYPE_MISMATCH . status-surface-type-mismatch) + (:CAIRO_STATUS_PATTERN_TYPE_MISMATCH . status-pattern-type-mismatch) + (:CAIRO_STATUS_INVALID_CONTENT . status-invalid-content) + (:CAIRO_STATUS_INVALID_FORMAT . status-invalid-format) + (:CAIRO_STATUS_INVALID_VISUAL . status-invalid-visual) + (:CAIRO_STATUS_FILE_NOT_FOUND . status-file-not-found) + (:CAIRO_STATUS_INVALID_DASH . status-invalid-dash) + (:CAIRO_STATUS_INVALID_DSC_COMMENT . status-invalid-dsc-comment) + (:CAIRO_STATUS_INVALID_INDEX . status-invalid-index) + (:CAIRO_STATUS_CLIP_NOT_REPRESENTABLE . status-clip-not-representable))) (defun lookup-cairo-enum (cairo-enum table) (let ((enum (cdr (assoc cairo-enum table)))) Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Sat Jul 21 09:41:55 2007 @@ -75,7 +75,7 @@ (set-source-rgb 1 1 1) (fill-path) ;; setup font -(select-font-face "Arial" 'normal 'normal) +(select-font-face "Arial" 'font-slant-normal 'font-weight-normal) (set-font-size size) ;; starting point (mark-at x y 2 1 0 0) ; red @@ -129,7 +129,7 @@ (set-source-rgb 0 0 1) (stroke) ;; "cl-cairo2" in Arial bold to the center -(select-font-face "Arial" 'normal 'bold) +(select-font-face "Arial" 'font-slant-normal 'font-weight-bold) (set-font-size 100) (set-source-rgba 1 0.75 0 0.5) ; orange (show-text-aligned "cl-cairo2" (/ size 2) (/ size 2)) @@ -159,7 +159,7 @@ (defparameter width 1024) (defparameter height 768) (defparameter max-angle 40d0) -(with-png-file ("hearts.png" 'rgb24 width height) +(with-png-file ("hearts.png" 'format-rgb24 width height) ;; fill with white (rectangle 0 0 width height) (set-source-rgb 1 1 1) Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Sat Jul 21 09:41:55 2007 @@ -54,10 +54,10 @@ \href{http://cairographics.org/}{Cairo} is a 2D graphics library with support for multiple output devices. The \lstinline!cl-cairo2! -package provides Common Lisp bindings for the Cairo API. Alternatives +package provides Common Lisp bindings for the Cairo API.\footnote{Alternatives are \href{http://www.cliki.net/cl-cairo}{cl-cairo}, written by Lars -Nostdal and others (which appears to be dormant), and Christian -Haselbach's \href{http://www.cliki.net/cffi-cairo}{cffi-cairo}. +Nostdal and others (this project appears to be dormant), and Christian +Haselbach's \href{http://www.cliki.net/cffi-cairo}{cffi-cairo}.} \lstinline!cl-cairo2! is written with the following principles in mind: @@ -159,7 +159,7 @@ write this to the bitmap file when you are done. The macro \lstinline!with-png-file! will take care of these details: use it like \begin{lstlisting} -(with-png-file ("example.png" 'rgb24 200 100) +(with-png-file ("example.png" 'format-rgb24 200 100) ;; drawing commands ...) \end{lstlisting} @@ -171,10 +171,10 @@ lookup tables (assoc lists) for this purpose, which are defined in \verb!tables.lisp!. Cairo constants \texttt{CAIRO\_\textsl{PROPERTY}\_\textsl{SOMETHING}} usually map to -the Lisp symbol \lstinline!something!, and can only be used in setting -or querying \texttt{PROPERTY}. For example, \verb!CAIRO_FORMAT_RGB24! -is mapped to \lstinline!rgb24!, and using it for some other property -will create an error. +the Lisp symbol \lstinline!property-something!, and can only be used +in setting or querying \texttt{PROPERTY}. For example, +\verb!CAIRO_FORMAT_RGB24! is mapped to \lstinline!format-rgb24!, and +using it for some other property will create an error. Likewise, names of the Lisp function are easy to deduce from the name of the C function in the Cairo API: just drop the \verb!cairo_! prefix @@ -290,7 +290,7 @@ \verb!text.lisp! for an enumeration of what is missing). You can select font face and size using commands like \begin{lstlisting} - (select-font-face "Arial" 'italic 'bold) + (select-font-face "Arial" 'font-slant-italic 'font-weight-bold) (select-font-size 12) \end{lstlisting} and use \lstinline!(show-text "hello world")! to draw it. You can

1 0

[cl-cairo2-cvs] r7 - tutorial
by tpapp＠common-lisp.net 12 Jul '07

12 Jul '07

Author: tpapp Date: Thu Jul 12 10:01:08 2007 New Revision: 7 Added: tutorial/test-finalizer.lisp Modified: Makefile cairo.lisp cl-cairo2-swig.lisp cl-cairo2.asd cl-cairo2.i context.lisp package.lisp path.lisp surface.lisp tables.lisp transformations.lisp tutorial/tutorial.tex xlib-context.lisp Log: Code cleanup, also added finalizers Modified: Makefile ============================================================================== --- Makefile (original) +++ Makefile Thu Jul 12 10:01:08 2007 @@ -1,4 +1,7 @@ -cl-cairo2-swig.lisp: cl-cairo2.i +CAIRO_INCLUDE_DIR=/usr/include/cairo +CAIRO_INCLUDE_FILES=$(wildcard $(CAIRO_INCLUDE_DIR)/*.h) + +cl-cairo2-swig.lisp: cl-cairo2.i $(CAIRO_INCLUDE_FILES) swig -cffi cl-cairo2.i test-swig.lisp: test.i Modified: cairo.lisp ============================================================================== --- cairo.lisp (original) +++ cairo.lisp Thu Jul 12 10:01:08 2007 @@ -1,10 +1,12 @@ (in-package :cl-cairo2) -(define-foreign-library libcairo - (:unix (:or "libcairo.so.2" "libcairo.so")) - (t (:default "libcairo"))) +;; (define-foreign-library libcairo +;; (:unix (:or "libcairo.so.2" "libcairo.so")) +;; (t (:default "libcairo"))) -(use-foreign-library libcairo) +;; (use-foreign-library libcairo) + +(load-foreign-library '(:default "libcairo")) (defun deg-to-rad (deg) "Convert degrees to radians." Modified: cl-cairo2-swig.lisp ============================================================================== --- cl-cairo2-swig.lisp (original) +++ cl-cairo2-swig.lisp Thu Jul 12 10:01:08 2007 @@ -2,10 +2,10 @@ (in-package :cl-cairo2) (defctype my-double :double) -;; (defmethod expand-to-foreign (value (type (eql 'my-double))) -;; `(coerce ,value 'double-float)) -(defmethod translate-to-foreign (value (type (eql 'my-double))) - (coerce value 'double-float)) +(defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) + `(coerce ,value 'double-float)) +;; (defmethod translate-to-foreign (value (type my-double)) +;; (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots @@ -81,9 +81,7 @@ (cl:defconstant CAIRO_VERSION_MINOR 4) -(cl:defconstant CAIRO_VERSION_MICRO 6) - -(cl:defconstant CAIRO_VERSION_STRING "1.4.6") +(cl:defconstant CAIRO_VERSION_MICRO 10) (cl:defconstant CAIRO_HAS_SVG_SURFACE 1) Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Jul 12 10:01:08 2007 @@ -1,6 +1,6 @@ (defsystem cl-cairo2 :description "Cairo 1.4 bindings" - :version "0.2" + :version "0.2.1" :author "Tamas K Papp" :license "GPL" :components ((:file "package") @@ -8,10 +8,10 @@ (:file "cl-cairo2-swig" :depends-on ("cairo")) (:file "tables" :depends-on ("cl-cairo2-swig")) (:file "surface" :depends-on ("cairo" "tables" "cl-cairo2-swig")) - (:file "context" :depends-on ("surface" "cl-cairo2-swig")) - (:file "path" :depends-on ("context")) ; "cl-cairo2-swig")) - (:file "text" :depends-on ("context")) ; "cl-cairo2-swig")) - (:file "transformations" :depends-on ("context")) ; "cl-cairo2-swig"))) + (:file "context" :depends-on ("surface" "tables" "cl-cairo2-swig")) + (:file "path" :depends-on ("context")) + (:file "text" :depends-on ("context")) + (:file "transformations" :depends-on ("context")) (:file "xlib-context" :depends-on ("context") :in-order-to ((load-op (feature :unix)) (compile-op (feature :unix))))) Modified: cl-cairo2.i ============================================================================== --- cl-cairo2.i (original) +++ cl-cairo2.i Thu Jul 12 10:01:08 2007 @@ -1,6 +1,7 @@ %module "cl-cairo2-swig" %ignore CAIRO_VERSION; +%ignore CAIRO_VERSION_STRING; %typemap(cin) double "my-double"; /* %typemap(cin) int ":my-int"; */ @@ -9,10 +10,10 @@ (in-package :cl-cairo2) (defctype my-double :double) -;; (defmethod expand-to-foreign (value (type (eql 'my-double))) -;; `(coerce ,value 'double-float)) -(defmethod translate-to-foreign (value (type (eql 'my-double))) - (coerce value 'double-float)) +(defmethod cffi:expand-to-foreign (value (type (eql 'my-double))) + `(coerce ,value 'double-float)) +;; (defmethod translate-to-foreign (value (type my-double)) +;; (coerce value 'double-float)) ;; typedefs: we don't want to create all of them automatically, ;; because typedefs for structures confuse with-foreign-slots Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Thu Jul 12 10:01:08 2007 @@ -29,14 +29,23 @@ (with-surface (surface pointer) (let ((context (make-instance 'context))) (setf (slot-value context 'pointer) (cairo_create pointer)) - ;; !!! error checking + ;; register finalizer + (let ((context-pointer (slot-value context 'pointer))) + (finalize context + #'(lambda () + (cairo_destroy context-pointer)))) + ;; return context context)))) (defmethod destroy ((object context)) (with-slots (pointer) object (when pointer (cairo_destroy pointer) - (setf pointer nil)))) + (setf pointer nil))) + ;; deregister finalizer + (cancel-finalization object)) + +(defgeneric sync (object)) (defmethod sync ((object context)) ;; most contexts don't need syncing @@ -46,7 +55,7 @@ ;;;; default context and convenience macros ;;;; -(export (defvar *context* nil "default cairo context")) +(defvar *context* nil "default cairo context") (defmacro with-context ((context pointer) &body body) "Execute body with pointer pointing to context, and check status." @@ -121,7 +130,6 @@ ;;;; simple functions using context ;;;; -(define-with-default-context save) (define-many-with-default-context (save) (restore) Modified: package.lisp ============================================================================== --- package.lisp (original) +++ package.lisp Thu Jul 12 10:01:08 2007 @@ -1,5 +1,13 @@ (defpackage :cl-cairo2 (:use :common-lisp :cffi) - (:export deg-to-rad - make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy - trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p)) + (:export ; !!! when the interface + ; stabilizes, remove export's + ; from all other places and + ; list them here + ;; utility functions + deg-to-rad + ;; context + *context* + ;; transformations + make-trans-matrix trans-matrix-xx trans-matrix-yx trans-matrix-xy + trans-matrix-yy trans-matrix-x0 trans-matrix-y0 trans-matrix-p)) Modified: path.lisp ============================================================================== --- path.lisp (original) +++ path.lisp Thu Jul 12 10:01:08 2007 @@ -10,7 +10,6 @@ (line-to x y) (move-to x y) (rectangle x y width height) - (rel-curve-to dx1 dy1 dx2 dy2 dx3 dy3) (rel-move-to dx dy) (rel-curve-to dx1 dy1 dx2 dy2 dx3 dy3) (rel-line-to dx dy) Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Thu Jul 12 10:01:08 2007 @@ -44,12 +44,17 @@ (let ((surface (make-instance 'surface))) (check-surface-pointer-status pointer (setf (slot-value surface 'pointer) pointer) + ;; register finalizer + (finalize surface #'(lambda () (cairo_surface_destroy pointer))) + ;; return surface surface))) (defmethod destroy ((object surface)) (with-alive-surface (object pointer) (cairo_surface_destroy pointer) - (setf pointer nil))) + (setf pointer nil)) + ;; deregister finalizer + (cancel-finalization object)) ;;;; ;;;; Macros to create surfaces (that are written into files) and Modified: tables.lisp ============================================================================== --- tables.lisp (original) +++ tables.lisp Thu Jul 12 10:01:08 2007 @@ -2,7 +2,8 @@ (defmacro exporting-table (name definition) `(progn - (export (defparameter ,name ,definition)) + (defparameter ,name ,definition) + (export ',name) (dolist (i ,name) ; (export (car i)) (export (cdr i))))) Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Thu Jul 12 10:01:08 2007 @@ -138,7 +138,7 @@ "Define a matrix transformation function with matrix and args, which returns the new matrix." `(export - (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) (matrix ,@args) + (defun ,(prepend-intern "trans-matrix-" name :replace-dash nil) (matrix ,@args) (with-trans-matrix-in-out matrix matrix-pointer (,(prepend-intern "cairo_matrix_" name) matrix-pointer @@ -169,6 +169,3 @@ (with-trans-matrix-in matrix matrix-pointer (with-x-y (cairo_matrix_transform_point matrix-pointer xp yp))))) - - - Added: tutorial/test-finalizer.lisp ============================================================================== --- (empty file) +++ tutorial/test-finalizer.lisp Thu Jul 12 10:01:08 2007 @@ -0,0 +1,13 @@ +(in-package :cl-cairo2) + +(setf *context* (create-pdf-context "/tmp/foo.pdf" 100 100)) +(move-to 0 0) +(line-to 100 100) +(set-source-rgb 0 0 1) +(stroke) + +;; destroy object, after this, it will be ready to be GC'd +(setf *context* nil) + +;; call GC +#+sbcl (sb-ext:gc) Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Thu Jul 12 10:01:08 2007 @@ -131,9 +131,11 @@ When the context is created from a surface, the reference count of the latter is incremented. You can immediately destroy the surface: it will not be destroyed (ie the file will not be closed) until you -destroy the context. The following code draws a white diagonal line -on a blue background, using a Postscript file -- the result is shown -in Figure~\ref{fig:example}. +destroy the context.\footnote{The file will also be closed if the + wrapper object is garbage collected. However, you should not rely + on this, as calling the garbage collector is not portable.} The +following code draws a white diagonal line on a blue background, using +a Postscript file -- the result is shown in Figure~\ref{fig:example}. \lstinputlisting[firstline=13,lastline=27]{example.lisp} Modified: xlib-context.lisp ============================================================================== --- xlib-context.lisp (original) +++ xlib-context.lisp Thu Jul 12 10:01:08 2007 @@ -69,12 +69,19 @@ (setf (slot-value xlc 'pointer) (mem-ref context-pointer :pointer)) (foreign-free xc-pointer) (foreign-free context-pointer) + ;; register finalizer + (let ((xc (slot-value xlc 'xc))) + (finalize xlc + #'(lambda () + (close_xlib_context xc)))) + ;; return object xlc)) (export 'create-xlib-context) (defmethod destroy ((object xlib-context)) - (close_xlib_context (slot-value object 'xc))) + (close_xlib_context (slot-value object 'xc)) + (cancel-finalization object)) (defmethod sync ((object xlib-context)) (sync_xlib (slot-value object 'xc)))

1 0

[cl-cairo2-cvs] r6 - cffi tutorial
by tpapp＠common-lisp.net 21 Jun '07

21 Jun '07

Author: tpapp Date: Thu Jun 21 05:07:42 2007 New Revision: 6 Added: README.xlib-context cffi/ cffi/Makefile cffi/xlib-context.c tutorial/xlib-example.lisp xlib-context.lisp Modified: Makefile cairo.lisp cl-cairo2.asd context.lisp surface.lisp text.lisp transformations.lisp tutorial/example.lisp tutorial/tutorial.tex Log: added svg and xlib support Modified: Makefile ============================================================================== --- Makefile (original) +++ Makefile Thu Jun 21 05:07:42 2007 @@ -9,4 +9,4 @@ mkdir /tmp/cl-cairo2-latest cp * -R /tmp/cl-cairo2-latest tar -cvzf /tmp/cl-cairo2-latest.tar.gz -C /tmp cl-cairo2-latest - gpg -b -a /tmp/cl-cairo2-latest.tar.gz \ No newline at end of file + gpg -b -a /tmp/cl-cairo2-latest.tar.gz Added: README.xlib-context ============================================================================== --- (empty file) +++ README.xlib-context Thu Jun 21 05:07:42 2007 @@ -0,0 +1,14 @@ +The xlib context is not part of cairo -- it is a bit of glue code that +uses cairo's X11 surface on a pixmap, and displays this pixmap when +needed (when X11 asks for the window contents to be redrawn or when +cairo draws on the pixmap). For the latter, it uses the XDamage +extension. + +The shared library that contains the glue code has to be compiled and +installed manually in /usr/local/lib/. Running + +make install + +as root from the cffi subdirectory should take care of this. You need +to have the XDamage library and header files (eg package +libxdamage-dev on Debian) installed. Modified: cairo.lisp ============================================================================== --- cairo.lisp (original) +++ cairo.lisp Thu Jun 21 05:07:42 2007 @@ -18,13 +18,15 @@ ;;;; commonly used macros/functions ;;;; -(defun prepend-intern (prefix name &optional (replace-dash t)) +(defun prepend-intern (prefix name &key (replace-dash t) (suffix "")) "Create and intern symbol PREFIXNAME from NAME, optionally - replacing dashes in name. PREFIX is converted to upper case." + replacing dashes in name. PREFIX is converted to upper case. + If given, suffix is appended at the end." (let ((name-as-string (symbol-name name))) (when replace-dash (setf name-as-string (substitute #\_ #\- name-as-string))) - (intern (concatenate 'string (string-upcase prefix) name-as-string)))) + (intern (concatenate 'string (string-upcase prefix) + name-as-string (string-upcase suffix))))) (defun copy-double-vector-to-pointer (vector pointer) "Copies vector of double-floats to a memory location." Added: cffi/Makefile ============================================================================== --- (empty file) +++ cffi/Makefile Thu Jun 21 05:07:42 2007 @@ -0,0 +1,10 @@ +INSTALL=/usr/local/lib + +install: xlib-context.so + cp xlib-context.so $(INSTALL) + +xlib-context.so: xlib-context.o + gcc -shared -o xlib-context.so xlib-context.o -lXdamage + +xlib-context.o: xlib-context.c + gcc -c -fPIC xlib-context.c -I /usr/include/cairo Added: cffi/xlib-context.c ============================================================================== --- (empty file) +++ cffi/xlib-context.c Thu Jun 21 05:07:42 2007 @@ -0,0 +1,210 @@ +#include <stdlib.h> +#include <stdio.h> +#include <X11/Xlib.h> +#include <X11/Xatom.h> +#include <X11/Xutil.h> +#include <X11/extensions/Xdamage.h> +#include <cairo-xlib.h> + +#define TRUE 1 +#define FALSE 0 + +/* #define DEBUG */ + +/* error codes */ +#define ERROR_OUTOFMEMORY 1 +#define ERROR_OPENDISPLAY 2 +#define ERROR_XDAMAGEMISSING 3 + +#define RETURN_ERROR(err) { free(xc); return (err); } + +/* structur */ +typedef struct { + unsigned int width; + unsigned int height; + Display *display; + int screen; + Window window; + Pixmap pixmap; + GC gc; +} xlib_context_data; + +/************************************************************************ + * create_xlib_context -- create an X11 window that acts as a context * + * * + * Parameters * + * display_name -- name of the X11 display, eg ":0" * + * window_name -- name of the X11 window * + * width, height -- width and height in pixels * + * xc_pointer -- see below * + * context_pointer -- points to the location which contains a pointer * + * to a cairo_t structure * + * * + * Notes * + * This function is meant to be called in a separate thread. If * + * successful, it allocates an xlib_context_data structure and puts * + * the pointer in *xc_pointer, and also initializes its contents with * + * the relevant data. A cairo_t context is created and assigned to * + * *context_pointer. * + * * + * The window has fixed size (width x height). The context is * + * attached to an X11 pixmap, which is copied onto the screen when * + * 1) X asks for the window contents to be redrawn, 2) the pixmap is * + * changed by cairo. The latter is handled via the X Damage * + * extension, which needs to be available. * + * * + * * + * * + ************************************************************************/ +int +create_xlib_context(char *display_name, + char *window_name, + unsigned int width, + unsigned int height, + xlib_context_data **xc_pointer, + cairo_t **context_pointer) +{ + Window root; /* root window */ + Visual *visual; /* visual */ + int depth; /* depth */ + XEvent ev; /* event */ + cairo_surface_t *surface; /* surface */ + Atom prots[1]; + int damage_event, damage_error; /* for querying extension */ + Damage damage; /* damage notification handler */ + XDamageNotifyEvent *dev; + cairo_t *context; + XSizeHints *hints; + + xlib_context_data *xc = (void *)NULL; + /* initialize pointer with NULL */ + *xc_pointer = NULL; + /* allocate xlib_context */ + xc = malloc( sizeof(xlib_context_data) ); + if (!xc) + RETURN_ERROR(ERROR_OUTOFMEMORY); + /* open display, get screen, root, visual, and depth */ + xc->display = XOpenDisplay(display_name); + if (!xc->display) + RETURN_ERROR( ERROR_OPENDISPLAY ); + xc->screen = DefaultScreen(xc->display); + root = RootWindow(xc->display, xc->screen); + visual = DefaultVisual(xc->display, xc->screen); + depth = DefaultDepth(xc->display, xc->screen); + /* check X damage extension */ + if (!XDamageQueryExtension( xc->display, &damage_event, &damage_error )) + RETURN_ERROR( ERROR_XDAMAGEMISSING ); + /* create window and pixmap */ + xc->window = XCreateSimpleWindow(xc->display, root, 0, 0, width, height, 0, 0, + WhitePixel (xc->display, xc->screen)); + xc->pixmap = XCreatePixmap(xc->display, xc->window, width, height, depth); + /* size hints */ + hints = XAllocSizeHints(); + hints->min_width = width; + hints->min_height = height; + hints->max_width = width; + hints->max_height = height; + hints->flags = PMinSize | PMaxSize; + XSetWMNormalHints(xc->display, xc->window, hints); + XFree(hints); + /* window name */ + XStoreName(xc->display,xc->window,window_name); + /* graphics context */ + xc->gc = XCreateGC(xc->display, xc->pixmap, 0, 0); + /* setup damage notification */ + damage = XDamageCreate( xc->display, xc->pixmap, XDamageReportNonEmpty ); + /* select events, map window */ + XSelectInput( xc->display, xc->window, + ExposureMask | StructureNotifyMask | KeyPressMask | KeyReleaseMask | + SubstructureNotifyMask ); + /* handle window closing */ + prots[0] = XInternAtom(xc->display, "WM_DELETE_WINDOW", FALSE); + XSetWMProtocols(xc->display, xc->window, prots, 1); + /* map window */ + XMapWindow(xc->display, xc->window); + /* allocate structure, create cairo surface */ + surface = cairo_xlib_surface_create( xc->display, xc->pixmap, visual, + width, height ); + context = cairo_create(surface); + cairo_surface_destroy(surface); + /* set pointers before we start loop */ +#ifdef DEBUG + FILE *debug = fopen("/tmp/debug","w"); + fprintf(debug, "before setting: xc_pointer=%p *xc_pointer=%p context_pointer=%p *context_pointer=%p\n", xc_pointer, *xc_pointer, context_pointer, *context_pointer); +#endif /* DEBUG */ + *xc_pointer = xc; + *context_pointer = context; +#ifdef DEBUG + fprintf(debug, "xc=%p=%p context=%p=%p\n", xc, *xc_pointer, + context, *context_pointer); + fprintf(debug, "damage_event=%d, XDamageNotify=%d\n", damage_event, XDamageNotify); + fflush(debug); +#endif /* DEBUG */ + /* main loop */ + for (;;) { + XNextEvent(xc->display, &ev); +#ifdef DEBUG + fprintf(debug, "event of type %d\n", ev.type); + fflush(debug); +#endif /* DEBUG */ + if (ev.type == (damage_event + XDamageNotify)) { + dev = (XDamageNotifyEvent *) &ev; +#ifdef DEBUG + fprintf(debug, "damage event received\n"); + fflush(debug); +#endif /* DEBUG */ + /* !!!! should only update the rectangle */ + XCopyArea(xc->display, xc->pixmap, xc->window, xc->gc, 0, 0, + width, height, 0, 0); + XDamageSubtract( xc->display, dev->damage, None, None ); + } else { + switch (ev.type) { + case Expose: +#ifdef DEBUG + fprintf(debug, "expose event received\n"); + fflush(debug); +#endif /* DEBUG */ + if (ev.xexpose.count > 0) + break; + /* !!!! should only update the rectangle */ + XCopyArea(xc->display, xc->pixmap, xc->window, xc->gc, 0, 0, + width, height, 0, 0); + break; + case DestroyNotify: + case ClientMessage: + /* cleanup & close */ + XDamageDestroy( xc->display, damage ); + XDestroyWindow( xc->display, xc->window ); + XCloseDisplay( xc->display ); +#ifdef DEBUG + fprintf(debug,"cleaning up\n"); + fclose(debug); +#endif /* DEBUG */ + free(xc); + return(0); + default: + break; + } + } + } +} + +/************************************************************************ + * close_xlib_context -- send a destroy even to the window * + * * + * Note * + * We just send the event, all the cleanup will be done by the * + * event handler loop. * + ************************************************************************/ +void close_xlib_context(xlib_context_data *xc) +{ + XEvent ev; + ev.type = DestroyNotify; + XSendEvent(xc->display, xc->window, FALSE, 0, &ev); + XFlush(xc->display); +} + +void sync_xlib(xlib_context_data *xc) +{ + XFlush(xc->display); +} Modified: cl-cairo2.asd ============================================================================== --- cl-cairo2.asd (original) +++ cl-cairo2.asd Thu Jun 21 05:07:42 2007 @@ -1,6 +1,6 @@ (defsystem cl-cairo2 :description "Cairo 1.4 bindings" - :version "0.1" + :version "0.2" :author "Tamas K Papp" :license "GPL" :components ((:file "package") @@ -11,5 +11,8 @@ (:file "context" :depends-on ("surface" "cl-cairo2-swig")) (:file "path" :depends-on ("context")) ; "cl-cairo2-swig")) (:file "text" :depends-on ("context")) ; "cl-cairo2-swig")) - (:file "transformations" :depends-on ("context"))) ; "cl-cairo2-swig"))) + (:file "transformations" :depends-on ("context")) ; "cl-cairo2-swig"))) + (:file "xlib-context" :depends-on ("context") + :in-order-to ((load-op (feature :unix)) + (compile-op (feature :unix))))) :depends-on (:cffi)) Modified: context.lisp ============================================================================== --- context.lisp (original) +++ context.lisp Thu Jun 21 05:07:42 2007 @@ -38,6 +38,10 @@ (cairo_destroy pointer) (setf pointer nil)))) +(defmethod sync ((object context)) + ;; most contexts don't need syncing + ) + ;;;; ;;;; default context and convenience macros ;;;; @@ -66,6 +70,16 @@ (with-context (context pointer) (,(prepend-intern "cairo_" name) pointer ,@args))))) +(defmacro define-with-default-context-sync (name &rest args) + "Define cairo function with *context* as its first argument and + args as the rest, automatically mapping name to the appropriate + cairo function. sync will be called after the operation." + `(export + (defun ,name (,@args &optional (context *context*)) + (with-context (context pointer) + (,(prepend-intern "cairo_" name) pointer ,@args)) + (sync context)))) + (defmacro define-flexible ((name pointer &rest args) &body body) "Like define-with-default context, but with arbitrary body, pointer will point to the context." @@ -85,20 +99,23 @@ (defmacro define-get-set (property) "Define set-property and get-property functions." `(progn - (define-with-default-context ,(prepend-intern "get-" property nil)) - (define-with-default-context ,(prepend-intern "set-" property nil) ,property))) + (define-with-default-context ,(prepend-intern "get-" property :replace-dash nil)) + (define-with-default-context ,(prepend-intern "set-" property :replace-dash nil) + ,property))) (defmacro define-get-set-using-table (property) "Define set-property and get-property functions, where property is looked up in table-property for conversion into Cairo's enum constants." `(progn - (define-flexible (,(prepend-intern "get-" property nil) pointer) - (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer) - ,(prepend-intern "table-" property nil))) - (define-flexible (,(prepend-intern "set-" property nil) pointer ,property) - (,(prepend-intern "cairo_set_" property) pointer - (lookup-enum ,property ,(prepend-intern "table-" property nil)))))) + (define-flexible (,(prepend-intern "get-" property :replace-dash nil) pointer) + (lookup-cairo-enum (,(prepend-intern "cairo_get_" property) pointer) + ,(prepend-intern "table-" property :replace-dash nil))) + (define-flexible (,(prepend-intern "set-" property :replace-dash nil) + pointer ,property) + (,(prepend-intern "cairo_set_" property) pointer + (lookup-enum ,property ,(prepend-intern "table-" + property :replace-dash nil)))))) ;;;; ;;;; simple functions using context @@ -116,14 +133,15 @@ (clip) (clip-preserve) (reset-clip) - (fill-preserve) - (paint) - (paint-with-alpha alpha) - (stroke) - (stroke-preserve) (copy-page) (show-page)) +(define-with-default-context-sync fill-preserve) +(define-with-default-context-sync paint) +(define-with-default-context-sync paint-with-alpha alpha) +(define-with-default-context-sync stroke) +(define-with-default-context-sync stroke-preserve) + ;;;; ;;;; functions that get/set a property without any conversion ;;;; @@ -142,11 +160,11 @@ (define-get-set-using-table line-join) (define-get-set-using-table operator) - ;; fill-path: it should simply be fill, but it is renamed so it does ;; not clash with cl-user:fill (define-flexible (fill-path pointer) - (cairo_fill pointer)) + (cairo_fill pointer) + (sync context)) (define-flexible (set-dash pointer offset dashes) (let ((num-dashes (length dashes))) Modified: surface.lisp ============================================================================== --- surface.lisp (original) +++ surface.lisp Thu Jun 21 05:07:42 2007 @@ -13,7 +13,7 @@ ;;;; class surface ;;;; -(defclass surface () ((pointer :initform nil))) +(defclass surface () ((pointer :initarg :pointer :initform nil))) (defmacro with-alive-surface ((surface pointer) &body body) "Execute body with pointer pointing to cairo surface, if nil, @@ -52,46 +52,54 @@ (setf pointer nil))) ;;;; -;;;; PDF surface +;;;; Macros to create surfaces (that are written into files) and +;;;; direct creation of contexts for these surfaces. ;;;; -(export - (defun create-pdf-surface (filename width-in-points height-in-points) - (new-surface-with-check - (cairo_pdf_surface_create filename - width-in-points - height-in-points)))) +(defmacro define-create-surface (type) + `(export + (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-surface") + (filename width-in-points height-in-points) + (new-surface-with-check + (,(prepend-intern "cairo_" type :replace-dash nil + :suffix "_surface_create") + filename width-in-points height-in-points))))) + +(defmacro define-create-context (type) + `(export + (defun ,(prepend-intern "create-" type :replace-dash nil :suffix "-context") + (filename width-in-points height-in-points) + "Create a surface, then a context for a file, then +destroy (dereference) the surface. The user only needs to +destroy the context when done." + (let* ((surface (,(prepend-intern "create-" + type :replace-dash nil :suffix "-surface") + filename width-in-points height-in-points)) + (context (create-context surface))) + (destroy surface) + context)))) -(export - (defun create-pdf-context (filename width-in-points height-in-points) - "Create a surface, then a context for a pdf file, then - destroy (dereference) the surface. The user only needs to - destroy the context when done." - (let* ((surface (create-pdf-surface filename width-in-points height-in-points)) - (context (create-context surface))) - (destroy surface) - context))) + +;;;; +;;;; PDF surface +;;;; + +(define-create-surface pdf) +(define-create-context pdf) ;;;; ;;;; PostScript surface ;;;; -(export - (defun create-ps-surface (filename width-in-points height-in-points) - (new-surface-with-check - (cairo_ps_surface_create filename - width-in-points - height-in-points)))) +(define-create-surface ps) +(define-create-context ps) -(export - (defun create-ps-context (filename width-in-points height-in-points) - "Create a surface, then a context for a postscript file, then - destroy (dereference) the surface. The user only needs to - destroy the context when done." - (let* ((surface (create-ps-surface filename width-in-points height-in-points)) - (context (create-context surface))) - (destroy surface) - context))) +;;;; +;;;; SVG surface +;;;; + +(define-create-surface svg) +(define-create-context svg) ;;;; ;;;; image surface Modified: text.lisp ============================================================================== --- text.lisp (original) +++ text.lisp Thu Jun 21 05:07:42 2007 @@ -37,4 +37,4 @@ extents-pointer cairo_text_extents_t) (values x_bearing y_bearing width height x_advance y_advance)))) -(define-with-default-context show-text text) +(define-with-default-context-sync show-text text) Modified: transformations.lisp ============================================================================== --- transformations.lisp (original) +++ transformations.lisp Thu Jun 21 05:07:42 2007 @@ -123,7 +123,7 @@ "Define a matrix initializer function with args, which returns the new matrix." `(export - (defun ,(prepend-intern "trans-matrix-init-" name nil) ,args + (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) ,args (with-trans-matrix-out matrix-pointer (,(prepend-intern "cairo_matrix_init_" name) matrix-pointer @@ -138,7 +138,7 @@ "Define a matrix transformation function with matrix and args, which returns the new matrix." `(export - (defun ,(prepend-intern "trans-matrix-init-" name nil) (matrix ,@args) + (defun ,(prepend-intern "trans-matrix-init-" name :replace-dash nil) (matrix ,@args) (with-trans-matrix-in-out matrix matrix-pointer (,(prepend-intern "cairo_matrix_" name) matrix-pointer Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Thu Jun 21 05:07:42 2007 @@ -6,7 +6,29 @@ (in-package :cairo-example) +;;;; +;;;; short example for the tutorial +;;;; + +(defparameter *surface* (create-ps-surface "example.ps" 200 100)) +(setf *context* (create-context *surface*)) +(destroy *surface*) +;; clear the whole canvas with blue +(rectangle 0 0 200 100) +(set-source-rgb 0.2 0.2 1) +(fill-path) +;; draw a white diagonal line +(move-to 200 0) +(line-to 0 100) +(set-source-rgb 1 1 1) +(set-line-width 5) +(stroke) +;; destroy context, this also destroys the surface and closes the file +(destroy *context*) + +;;;; ;;;; helper functions +;;;; (defun show-text-aligned (text x y &optional (x-align 0.5) (y-align 0.5) (context *context*)) @@ -150,25 +172,3 @@ (scale scaling scaling) ; scale (rotate (deg-to-rad (- (random (* 2 max-angle)) max-angle 180))) ; rotate (heart (+ 0.1 (random 0.7)))))) - - -;;;; -;;;; short example for the tutorial -;;;; - -(defparameter *surface* (create-ps-surface "example.ps" 200 100)) -(setf *context* (create-context *surface*)) -(destroy *surface*) -;; clear the whole canvas with blue -(rectangle 0 0 200 100) -(set-source-rgb 0.2 0.2 1) -(fill-path) -;; draw a white diagonal line -(move-to 0 0) -(line-to 200 100) -(set-source-rgb 1 1 1) -(set-line-width 5) -(stroke) -;; destroy context, this also destroys the surface and closes the file -(destroy *context*) - Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Thu Jun 21 05:07:42 2007 @@ -135,7 +135,7 @@ on a blue background, using a Postscript file -- the result is shown in Figure~\ref{fig:example}. -\lstinputlisting[firstline=159,lastline=173]{example.lisp} +\lstinputlisting[firstline=13,lastline=27]{example.lisp} \begin{figure}[htbp] \centering @@ -223,9 +223,12 @@ \lstinline!new-surface-with-check! makes a new surface object from a pointer, checking its status first. -Currently, only Postscript, PDF and image surfaces (which can be +Currently, only Postscript, PDF, SVG and image surfaces (which can be written to PNG files) are supported. +Drawing in X11 windows is implemented using the +\lstinline!xlib-context! class --- see Section~\ref{sec:xlib-context} +for more information. \subsection{Contexts} \label{sec:contexts} @@ -318,6 +321,35 @@ with \lstinline!trans-matrix-!, and other a few other functions have been renamed to avoid conflicts with linear algebra packages. +\subsection{Xlib Contexts} +\label{sec:xlib-context} + +The xlib context is not part of cairo -- it is a bit of glue code that +uses cairo's X11 surface on a pixmap, and displays this pixmap when +needed (when X11 asks for the window contents to be redrawn or when +cairo draws on the pixmap). For the latter, it uses the XDamage +extension. + +The X11 event loop runs in a separate thread, so you need a Lisp +implementation that supports threads. The surface is not exposed to +the user, who is only allowed to see the context. This makes memory +management and proper cleanup easier. + +\textbf{Important:} before proceeding, make sure that you read +\verb!README.xlib-context! on how to install the shared library with +the necessary code. + +You can create Xlib contexts with +\begin{lstlisting} + (create-xlib-context width height) +\end{lstlisting} +When \lstinline!destroy!ed, the window is closed. This works the +other way too: when the window is closed, the context is destroyed. + +Example code can be found in \verb!tutorial/xlib-example.lisp!. The +current implementation is not optimized for speed (the whole window is +redrawn all the time) but it is fast enough for me. If you need speed +improvements desperately, please contact the author. \subsection{To Do} \label{sec:todo} @@ -325,9 +357,7 @@ The list below reflects my priorities. If you need something, please let me know. \begin{itemize} -\item X-Window surface \item patterns (should be easy) -\item SVG surfaces (should be quick \& easy) \item Win32 surfaces (I can't do it, I don't use Windows) \item CLOS integration for fonts (as suggested \href{http://www.cairographics.org/manual/bindings-fonts.html}{here}) @@ -370,18 +400,6 @@ \label{fig:hearts} \end{figure} - - - - - - - - - -% \bibliographystyle{apalike} -% \bibliography{/home/tpapp/doc/general.bib} - \end{document} %%% Local Variables: Added: tutorial/xlib-example.lisp ============================================================================== --- (empty file) +++ tutorial/xlib-example.lisp Thu Jun 21 05:07:42 2007 @@ -0,0 +1,57 @@ +(asdf:operate 'asdf:load-op :cl-cairo2) + +;;;; Make a test package +(defpackage :cairo-xlib-example + (:use :common-lisp :cl-cairo2)) + +(in-package :cairo-xlib-example) + +(let ((width 400) + (height 300)) + (setf *context* (create-xlib-context width height)) + ;; clear the whole canvas with blue + (rectangle 0 0 width height) + (set-source-rgb 0.2 0.2 0.5) + (fill-path) + ;; draw a white diagonal line + (move-to width 0) + (line-to 0 height) + (set-source-rgb 1 1 1) + (set-line-width 5) + (stroke) + ;; draw a green diagonal line + (move-to 0 0) + (line-to width height) + (set-source-rgb 0 1 0) + (set-line-width 5) + (stroke)) +;; need to close window manually + + +(defun random-square (alpha) + "Draw a blue rectangle with fixed size and the given transparency alpha." + (move-to 1 1) + (line-to -1 1) + (line-to -1 -1) + (line-to 1 -1) + (close-path) + (set-source-rgba 0 0 1 alpha) + (fill-path)) + +(defparameter width 800) +(defparameter height 600) +(defparameter max-angle 90d0) +(setf *context* (create-xlib-context width height)) +;; fill with white +(rectangle 0 0 width height) +(set-source-rgb 1 1 1) +(fill-path) +;; draw the rectangles +(dotimes (i 500) + (let ((scaling (+ 5d0 (random 40d0)))) + (reset-matrix) ; reset matrix + (translate (random width) (random height)) ; move the origin + (scale scaling scaling) ; scale + (rotate (deg-to-rad (random max-angle))) ; rotate + (random-square (+ 0.1 (random 0.4))))) +;; need to close window manually Added: xlib-context.lisp ============================================================================== --- (empty file) +++ xlib-context.lisp Thu Jun 21 05:07:42 2007 @@ -0,0 +1,80 @@ +(in-package :cl-cairo2) + +;;;; +;;;; a little glue code loaded as a shared library +;;;; + +;; modify path if needed +(load-foreign-library "/usr/local/lib/xlib-context.so") + +;; code to make threads, please extend with your own Lisp if needed +;; testing is welcome, I only tested cmucl and sbcl +(defun start-thread (function name) + #+allegro (mp:process-run-function name function) + #+armedbear (ext:make-thread function :name name) + #+cmu (mp:make-process function :name name) + #+lispworks (mp:process-run-function name nil function) + #+openmcl (ccl:process-run-function name function) + #+sbcl (sb-thread:make-thread function :name name)) + +;;;; +;;;; CFFI interface +;;;; + +(cffi:defcfun ("create_xlib_context" create_xlib_context) :int + (display_name :string) + (window_name :string) + (width :unsigned-int) + (height :unsigned-int) + (xc-pointer :pointer) + (context-pointer :pointer)) + +(cffi:defcfun ("close_xlib_context" close_xlib_context) :void + (xc-pointer :pointer)) + +(cffi:defcfun ("sync_xlib" sync_xlib) :void + (xc-pointer :pointer)) + + +;;;; xlib-context class + +(defclass xlib-context (context) (xc thread)) + +(defun create-xlib-context (width height &key (display-name ":0") + (window-name "cl-cairo2")) + "Create a cairo context that draws to an X11 window of specified size." + (let ((xlc (make-instance 'xlib-context)) + (xc-pointer (foreign-alloc :pointer)) + (context-pointer (foreign-alloc :pointer))) + ;; we will detect changes with null-pointer-p + (setf (mem-ref xc-pointer :pointer) (null-pointer)) + (setf (mem-ref context-pointer :pointer) (null-pointer)) + ;; start and save thread + (setf (slot-value xlc 'thread) + (start-thread + (lambda () + (let ((err (create_xlib_context display-name window-name width height + xc-pointer context-pointer))) + (unless (zerop err) + (error "Error ~a when creating xlib-context." err))) + ;; set slots to nil when done + (with-slots (xc pointer) xlc + (setf xc nil) + (setf pointer nil))) + "cl-cairo2")) + ;; extract slots + (do () ; wait for thread to fill pointers + ((not (null-pointer-p (mem-ref context-pointer :pointer))))) + (setf (slot-value xlc 'xc) (mem-ref xc-pointer :pointer)) + (setf (slot-value xlc 'pointer) (mem-ref context-pointer :pointer)) + (foreign-free xc-pointer) + (foreign-free context-pointer) + xlc)) + +(export 'create-xlib-context) + +(defmethod destroy ((object xlib-context)) + (close_xlib_context (slot-value object 'xc))) + +(defmethod sync ((object xlib-context)) + (sync_xlib (slot-value object 'xc)))

1 0

[cl-cairo2-cvs] r5 - tutorial
by tpapp＠common-lisp.net 04 Jun '07

04 Jun '07

Author: tpapp Date: Mon Jun 4 03:13:31 2007 New Revision: 5 Modified: tutorial/Makefile tutorial/tutorial.tex Log: Tutorial now uses eps files. Modified: tutorial/Makefile ============================================================================== --- tutorial/Makefile (original) +++ tutorial/Makefile Mon Jun 4 03:13:31 2007 @@ -1,5 +1,8 @@ tutorial.pdf: tutorial.dvi dvipdfm tutorial -tutorial.dvi: tutorial.tex hearts.png lissajous.ps text.ps example.ps +tutorial.dvi: tutorial.tex hearts.png lissajous.epsi text.epsi example.epsi latex tutorial.tex + +%.epsi: %.ps + ps2epsi $< $@ Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Mon Jun 4 03:13:31 2007 @@ -139,7 +139,7 @@ \begin{figure}[htbp] \centering - \includegraphics{example.ps} + \includegraphics{example.epsi} \caption{white diagonal line on a blue background} \label{fig:example} \end{figure} @@ -351,14 +351,14 @@ \begin{figure}[htbp] \centering - \includegraphics[height=8cm]{text.ps} + \includegraphics[height=8cm]{text.epsi} \caption{text.pdf} \label{fig:text} \end{figure} \begin{figure}[htbp] \centering - \includegraphics[height=8cm]{lissajous.ps} + \includegraphics[height=8cm]{lissajous.epsi} \caption{lissajous.pdf} \label{fig:lissajous} \end{figure}

1 0

[cl-cairo2-cvs] r4 - tutorial
by tpapp＠common-lisp.net 30 May '07

30 May '07

Author: tpapp Date: Tue May 29 22:35:50 2007 New Revision: 4 Removed: tutorial/.tex Log: Deleted cruft

1 0

[cl-cairo2-cvs] r3 - tutorial
by tpapp＠common-lisp.net 30 May '07

30 May '07

Author: tpapp Date: Tue May 29 22:23:32 2007 New Revision: 3 Removed: tutorial/tutorial.lisp Modified: Makefile README tutorial/Makefile tutorial/example.lisp tutorial/tutorial.tex Log: Cleaned up examples Modified: Makefile ============================================================================== --- Makefile (original) +++ Makefile Tue May 29 22:23:32 2007 @@ -3,3 +3,10 @@ test-swig.lisp: test.i swig -cffi -generate-typedef test.i + +asdf: + rm -Rf /tmp/cl-cairo2-latest + mkdir /tmp/cl-cairo2-latest + cp * -R /tmp/cl-cairo2-latest + tar -cvzf /tmp/cl-cairo2-latest.tar.gz -C /tmp cl-cairo2-latest + gpg -b -a /tmp/cl-cairo2-latest.tar.gz \ No newline at end of file Modified: README ============================================================================== --- README (original) +++ README Tue May 29 22:23:32 2007 @@ -1,6 +1,6 @@ Please read the tutorial to get started. To compile the tutorial from source, you will need a reasonably complete LaTeX installation with -dvipdfm, and the pdftops utility. +dvipdfm. The project webpage is at http://common-lisp.net/project/cl-cairo2, where you will find the repository, mailing lists, contact information Modified: tutorial/Makefile ============================================================================== --- tutorial/Makefile (original) +++ tutorial/Makefile Tue May 29 22:23:32 2007 @@ -1,12 +1,5 @@ tutorial.pdf: tutorial.dvi dvipdfm tutorial -tutorial.dvi: tutorial.tex hearts.png lissajous.eps text.eps +tutorial.dvi: tutorial.tex hearts.png lissajous.ps text.ps example.ps latex tutorial.tex - -lissajous.eps: lissajous.pdf - pdftops -eps lissajous.pdf lissajous.eps - -text.eps: ../text.pdf - pdftops -eps text.pdf text.eps - Modified: tutorial/example.lisp ============================================================================== --- tutorial/example.lisp (original) +++ tutorial/example.lisp Tue May 29 22:23:32 2007 @@ -47,7 +47,7 @@ (defparameter size 50) (defparameter x 20) (defparameter y 50) -(setf *context* (create-pdf-context "text.pdf" width height)) +(setf *context* (create-ps-context "text.ps" width height)) ;; white background (rectangle 0 0 width height) (set-source-rgb 1 1 1) @@ -89,7 +89,7 @@ (defparameter b 8) (defparameter delta (/ pi 2)) (defparameter density 2000) -(setf *context* (create-pdf-context "lissajous.pdf" size size)) +(setf *context* (create-ps-context "lissajous.ps" size size)) ;; pastel blue background (rectangle 0 0 width height) (set-source-rgb 0.9 0.9 1) @@ -150,3 +150,25 @@ (scale scaling scaling) ; scale (rotate (deg-to-rad (- (random (* 2 max-angle)) max-angle 180))) ; rotate (heart (+ 0.1 (random 0.7)))))) + + +;;;; +;;;; short example for the tutorial +;;;; + +(defparameter *surface* (create-ps-surface "example.ps" 200 100)) +(setf *context* (create-context *surface*)) +(destroy *surface*) +;; clear the whole canvas with blue +(rectangle 0 0 200 100) +(set-source-rgb 0.2 0.2 1) +(fill-path) +;; draw a white diagonal line +(move-to 0 0) +(line-to 200 100) +(set-source-rgb 1 1 1) +(set-line-width 5) +(stroke) +;; destroy context, this also destroys the surface and closes the file +(destroy *context*) + Modified: tutorial/tutorial.tex ============================================================================== --- tutorial/tutorial.tex (original) +++ tutorial/tutorial.tex Tue May 29 22:23:32 2007 @@ -39,6 +39,7 @@ breaklines=true, % frame=single, columns=fullflexible, + literate={-}{}{0\discretionary{-}{}{-}}, } \begin{document} @@ -134,7 +135,7 @@ on a blue background, using a Postscript file -- the result is shown in Figure~\ref{fig:example}. -\lstinputlisting[firstline=3,lastline=17]{tutorial.lisp} +\lstinputlisting[firstline=159,lastline=173]{example.lisp} \begin{figure}[htbp] \centering @@ -346,18 +347,18 @@ \texttt{example.lisp}. Figures~\ref{fig:text}--\ref{fig:hearts} show the results. -\lstinputlisting{../example.lisp} +\lstinputlisting{example.lisp} \begin{figure}[htbp] \centering - \includegraphics[height=8cm]{text.eps} + \includegraphics[height=8cm]{text.ps} \caption{text.pdf} \label{fig:text} \end{figure} \begin{figure}[htbp] \centering - \includegraphics[height=8cm]{lissajous.eps} + \includegraphics[height=8cm]{lissajous.ps} \caption{lissajous.pdf} \label{fig:lissajous} \end{figure}

1 0

[cl-cairo2-cvs] r2 - .git
by tpapp＠common-lisp.net 28 May '07

28 May '07

Author: tpapp Date: Mon May 28 15:38:28 2007 New Revision: 2 Removed: .git/ svn-commit.2.tmp svn-commit.tmp Log: deleted leftover cruft

1 0