B.HllOd,dkm5lhI[mmd*8F+jA!:F*-\F]A4"5A$4\ZIs*_4&&5F_@DU4$WX[?
+ "_tRXZ^mr87^mWCik+(9F=kg'\9DrIA^7clVq/mI8B<2CHrAR>B[$]!J6rgEn"Eng'!u304
+ /gp;sbJ,'")iiSgFf?`7ZSmLPNoT)snW$;$i)SP#L3`'[ed,A7Q1rarZk>o2\WS^[__djqk
+ a7La``b/K7qq5-V\/5\1[PWjR7jl[%/in,;2'QS`d3gN9UOGDS2Y+l/AM"]B*?4/fVgok.:
+ :#OsUKi236u,?+t9a;;cg*g`W]TC6f!o**-\g-ZsqI| 1_PZ73s1@69hqIq`20F>JCALt3pFj
+ Q$#*tJ`.P;T:<;]3OiLBWH6Z_i-$CP&7dkZZUVS/O`qG'rZ3sgaLUd1I0_8CDt.&^lH.gkG
+ mN-A#)n&5A4ciU)+OZ=UACKPaT=AJ9g\TpQ9.(rJW4J]K/E+ul1-<8T`eprZVT>nlVN;&RG
+ l+AI#6s`Ct`%4d.QfMUY/jlQMTk]6qO]%*6%JBj&0$,E&;uj(AU_I.X&EFfC'hG8
+ o67!6oPu4N6UKBnfU76$!S$-J^Hp.)@5LZh18od-]*X=hi
+ Y+@c$>lQsqI5A7VVNO4_H[e3V&nnEm8t@%WFIc-Ju2;je/=^4@&OGA'ua"9]KIo(e5_77`_
+ c23.a^m8do7eaV))'d6fg"$Y*[<*;FM!o_GKu[Q&hboDYZ7DT4-g%-?Qd9?"6_UVke9(3j3
+ )a9"(DR#YM7mjR>c"Y@MZG.]XijPdi&^`J^I(3PmA?Cm5DoP.kl(N@n\=!\]i%V/kPT1)ML
+ #Ti)^W&Pa[=Tjel($:A*N;n]tCk8?\S/%rr!E=A,J:e;'ln5:-1.LYg2n&;ge@]4>9W
+ t2"sNRAs``.]O[WrmF)(O=8E"/,RAWoHVSH=GIjY0CLKXH-udGH-_qHV,ZnN;\jjF'gqTN2aR3(nf\.%F
+ bN(='c3&NO5+1_iAVYr!1+'Ts=`eSE5LS&&5Wn5=rW7$$W1J\Oe6&J-#Z1aAXaU8TCQh1Vp
+ hUME%-lU,YOPdk=INTAuT/i)u$>!?^G3,i5,=2Om;#l*P-Z/Q08Gd.gC?noSSe28/:=>VRo
+ 85fn/5gC_ol55-WhWcjlr;=^6r1RBuEVoH!lfO3r@AJfB`&L6F&/6G;!d0s*c7i(ZBI\nZ.
+ ub7>=GD_);@-Ys%V]7>),cglTIpt*WFCU^Bcd+IgAP,7k`Ut:j\m:Zo8F[N72J6.d3QBgU0
+ !A,r'u"mdr+u+UNH:9oYWh#Fh.73+tlpr'QUl(F=*s4&;%A[3JqG<8Qt3];ZIs\Kr*>f`?)
+ eo?dZE&FdBn4Z]hP!^YXi7R#B\YS/)NKJFbuspVbWJ;s.jEP,9k[7T$JPO@\F4RE8uu\mto
+ jUXK&90>aU,dXamPYY.1BQ;;hfe$OLgQ6R7B*$_)NjTo$Rl]FtijATsl\-ksfi$2t9*WCs0
+ n,Fni6Bi"q2VX-UVgC]82#c]h&?Kn?irp)^)[Jtp3W_t?):s6+cDr\!,Zs]rMBj7f"?`-_6R'#ce>44S?;d*k+H!g2.J(%7m)KXU4ccE])l
+ 5nSkm63,mZpW+OH7$7@kR!oXT*p6V!idF2q9gI-t[d77qPEtJ=+i\<2`7<&`>JI6@b7^&)o
+ _S-\%Y`Nj`#Lg::bGIp=OPUOs8(ICgUa4T'sVISa%p:1:<#f$J<4ABEdCOTT<`9Uee.VM-G
+ 8!`;5,)QH_]djmAf.DLbp*_G6RQ4?$CIXE[eK_Y)BFPr;R_]rmq4^h?=o;H-eIhXW)T]H=m
+ Jon5LA.q6[S-*baJ.O8=L.aMcTal3iM+6"fNpT)!]70]N19&74`nDl#F..^Bd<7NT?jq782
+ W\>s-,Ui2#]GXX'oR[[/-&2db2tks^(5+%;f?_un+-'gF)u6)'5O)p0)*(XbYTSb"f<:ZKn
+ pjZ$p-u]"E@,.26n2F+9\S)dsUuEEU)tmZ&-eqn"MFpZf^@,CY%,e%!,;'3D/6ADHVBo:QNC
+ XFpdb](-A*V:2ndKonnVIa&EBT2kJ3!`4Df[)t]R`D6@+
+ mn??qfl(W'tf97PJ#@k?+-"n%@B*,Hf"G?FtC21FTp'U(0.A2-=lYik\](AT\d\b@;pj198/Y)Zpkn12/Y)+u1=;PS#,%!,D_nNHnBucW#/N=cp
+ -'^3cOOpEtA2GE_kd&a-_O3fZA(jL0/;'obHUd4,Zt`rlmof.l'W*ruPUr;9E2Bu:9'8-(+]l"J2G\jl:>Q6Ubb.>*E)gW/]EQmHWT*0\knfaT19S`s8J)&?pLK2E-S#-;tV\=es5SR!%gL3NAc1@lIkg.6Q5q6l.<)VsF'OT=V5P3E-\^F0/ri0:![co*N=^DRjfrmn2E
+ 4%SpF4:M2W'KTq@CR)0`_P+HQ`Y$oD;C1/F'olOP!i@Nkh.(Q\Zc9
+ P8"_VT=e5&NaY@7j%[-I+7r"#bFL/bXJWANZ@Bfoa*Zeee'`Ve1]1g7ajdFMh!G(h1f%cJ.
+ `)BM=[1>c,u*2:\VX?9F"0$fs2q;+?N#80-CO\0oe87]H<(O0UM\h-O@Wp9Z23d
+ Tlf_/ge8n]a=qn$`quJj))@](\ML^YYJ%$F&?.n.0fq6Yc#N=>6fMt/5U!(F\?oX,&R$Jau
+ cj=/#(7V6iP1u5*WQuF:Y,_2=I*,1ku.<:#sf/n;Nb%2KpNtrVNU;.m$1.N/RNeaJVPrN>g
+ ?hF:-7/]O;hs"E9ki(\S%(7AP3iR!^9E$*=&GFH6^srNkY_-RFRbdof/e%1%-G66J#_^l2#
+ c^p?Cijj70F0OLH&'l3'N_@^3O=JTJu1\G4i2.&l+[Nc1g-M`F(Ia#HKG1[J`.V-L$GDh]7
+ (AD-J.?&@Iqrf*WE2n[eV]Z/cdY1\u/0Y4S&Q$*@\"r/VDO#TIJ#j:D$+^MsA#6)G8k2tWl
+ 7@W3m4OK?(g]$$Y/Sd95'%>#jd![APA
+ (;Xb3_N@plq"b!4[L)u%Xt-CP9WCd4Q`%mB6=k;-R>0W4/qi&G87GTa[ikSA0je&-E=rd:Z
+ ip)m*.?[K3%MV2W,ko,7nl^'Yj-KGJO)aCdqMd"*DW,Z+?0W^Dj(?u;*6c=Rh+p`6ee#nYt
+ 1'QHE\Z#H[Qm,kDf][U\*0U-=(;'sWh>GDA8L1rh%u\YuLqQaCP^6W5(K.:^2eJ8aMZ?b/7,)bn$#eT:tO!e+t':$m
+ CD5cjKP,G$,]_4s7:q-NZ*#Oqmjc0K==)A3B&B)['mi`f2[]Jq/N89Obee/<W\.?Hbh
+ R=cT]$%6\Q'&Rs'^2`YJ&Ln,57_#BM4SYLaaRe2)*+GiU1qnMRlo]re!f:?Fp]9LnlK7=3#
+ #@:?FJ40u$kmGkQhR$MU@@`l?PHh"BLUn[!s_ntS,~>
+Q
+Q Q
+showpage
+%%Trailer
+end
+%%EOF
diff --git a/apps/DemoCameraWebP/artwork.obj b/apps/DemoCameraWebP/artwork.obj
new file mode 100644
index 00000000..d10f1ce9
--- /dev/null
+++ b/apps/DemoCameraWebP/artwork.obj
@@ -0,0 +1,39 @@
+% TGIF
+state(0,33,100,0,0,1,16,1,9,1,1,0,0,1,0,1,0,'Courier',0,17,0,0,1,5,0,0,1,1,0,16,1,0,1,1,1,0,1056,1497,0,0,2880).
+unit("1 pixel/pixel").
+generated_by("pstoedit",0,"4.3").
+page(1,"",1).
+polygon('#41e81d',37,[
+ 99.5556,1278.05,87.5556,1302.05,77.3819,1302.05,77.3819,1291.71,53.3819,1291.71,53.3819,1302.05,43.5556,1302.05,41.9931,1302.05,
+ 37.3195,1303.31,32.2361,1306.74,28.8055,1311.83,27.5556,1316.49,27.5556,1318.05,27.5556,1430.05,27.5556,1431.61,28.8055,1436.28,
+ 32.2361,1441.37,37.3195,1444.8,41.9931,1446.05,43.5556,1446.05,219.556,1446.05,221.111,1446.05,225.778,1444.8,230.868,1441.37,
+ 234.292,1436.28,235.556,1431.61,235.556,1430.05,235.556,1318.05,235.556,1316.49,234.292,1311.83,230.868,1306.74,225.778,1303.31,
+ 221.111,1302.05,219.556,1302.05,175.556,1302.05,163.556,1278.05,99.5556,1278.05],1,0,1,0,1,0,0,0,0,0,'0',
+ "0000000000",[
+]).
+polygon('#777777',37,[
+ 99.5556,1278.05,87.5556,1302.05,77.3819,1302.05,77.3819,1291.71,53.3819,1291.71,53.3819,1302.05,43.5556,1302.05,41.9931,1302.05,
+ 37.3195,1303.31,32.2361,1306.74,28.8055,1311.83,27.5556,1316.49,27.5556,1318.05,27.5556,1430.05,27.5556,1431.61,28.8055,1436.28,
+ 32.2361,1441.37,37.3195,1444.8,41.9931,1446.05,43.5556,1446.05,219.556,1446.05,221.111,1446.05,225.778,1444.8,230.868,1441.37,
+ 234.292,1436.28,235.556,1431.61,235.556,1430.05,235.556,1318.05,235.556,1316.49,234.292,1311.83,230.868,1306.74,225.778,1303.31,
+ 221.111,1302.05,219.556,1302.05,175.556,1302.05,163.556,1278.05,99.5556,1278.05],0,5.03938,1,0,2,0,0,0,0,0,'5',
+ "0000000000",[
+]).
+polygon('#ffffff',41,[
+ 187.556,1374.05,187.556,1376.87,186.416,1385.34,183.152,1395.85,177.986,1405.36,171.153,1413.65,162.861,1420.48,153.354,1425.65,
+ 142.84,1428.92,134.375,1430.05,131.556,1430.05,128.729,1430.05,120.264,1428.92,109.75,1425.65,100.243,1420.48,91.9515,1413.65,
+ 85.118,1405.36,79.9515,1395.85,76.6875,1385.34,75.5556,1376.87,75.5556,1374.05,75.5556,1371.23,76.6875,1362.76,79.9515,1352.25,
+ 85.118,1342.74,91.9515,1334.45,100.243,1327.62,109.75,1322.45,120.264,1319.19,128.729,1318.05,131.556,1318.05,134.375,1318.05,
+ 142.84,1319.19,153.354,1322.45,162.861,1327.62,171.153,1334.45,177.986,1342.74,183.152,1352.25,186.416,1362.76,187.556,1371.23,
+ 187.556,1374.05],1,0,1,0,3,0,0,0,0,0,'0',
+ "00000000000",[
+]).
+polygon('#000000',41,[
+ 187.556,1374.05,187.556,1376.87,186.416,1385.34,183.152,1395.85,177.986,1405.36,171.153,1413.65,162.861,1420.48,153.354,1425.65,
+ 142.84,1428.92,134.375,1430.05,131.556,1430.05,128.729,1430.05,120.264,1428.92,109.75,1425.65,100.243,1420.48,91.9515,1413.65,
+ 85.118,1405.36,79.9515,1395.85,76.6875,1385.34,75.5556,1376.87,75.5556,1374.05,75.5556,1371.23,76.6875,1362.76,79.9515,1352.25,
+ 85.118,1342.74,91.9515,1334.45,100.243,1327.62,109.75,1322.45,120.264,1319.19,128.729,1318.05,131.556,1318.05,134.375,1318.05,
+ 142.84,1319.19,153.354,1322.45,162.861,1327.62,171.153,1334.45,177.986,1342.74,183.152,1352.25,186.416,1362.76,187.556,1371.23,
+ 187.556,1374.05],0,5.03938,1,0,4,0,0,0,0,0,'5',
+ "00000000000",[
+]).
diff --git a/apps/DemoCameraWebP/artwork.png b/apps/DemoCameraWebP/artwork.png
new file mode 100644
index 00000000..8cff87ad
Binary files /dev/null and b/apps/DemoCameraWebP/artwork.png differ
diff --git a/apps/DemoCameraWebP/main.scm b/apps/DemoCameraWebP/main.scm
new file mode 100644
index 00000000..fe0d576c
--- /dev/null
+++ b/apps/DemoCameraWebP/main.scm
@@ -0,0 +1,110 @@
+#|
+LambdaNative - a cross-platform Scheme framework
+Copyright (c) 2009-2014, University of British Columbia
+Copyright (c) 2026, Benson Muite
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or
+without modification, are permitted provided that the
+following conditions are met:
+
+* Redistributions of source code must retain the above
+copyright notice, this list of conditions and the following
+disclaimer.
+
+* Redistributions in binary form must reproduce the above
+copyright notice, this list of conditions and the following
+disclaimer in the documentation and/or other materials
+provided with the distribution.
+
+* Neither the name of the University of British Columbia nor
+the names of its contributors may be used to endorse or
+promote products derived from this software without specific
+prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+|#
+
+;; WebP camera example
+(define gui #f)
+
+(define background #f)
+(define default:background (list 4 4 (glCoreTextureCreate 4 4 (make-u8vector 16 #xff)) 0.1 0.1 .9 .9))
+
+(define camera-image (string-append (system-directory) (system-pathseparator) "vidcam.jpg"))
+(define camera-image2 (string-append (system-directory) (system-pathseparator) "vidcam.webp"))
+
+(define lastmodtime 0.)
+
+;; look for a new jpeg from the camera, create a downsampled webp, and load that as a texture
+
+(define (autoload)
+ (let* ((fileinfo (if (file-exists? camera-image) (file-info camera-image) #f))
+ (modtime (if fileinfo (time->seconds (file-info-last-modification-time fileinfo)) #f)))
+ (if (and gui background modtime (> modtime lastmodtime))
+ (let* ((gdf (gdFileOpen camera-image "r"))
+ (gd (gdImageCreateFromJpeg gdf))
+ (w (gdImageSX gd))
+ (h (gdImageSY gd))
+ (w2 256)
+ (h2 (fix (* w2 (/ h w))))
+ (gdf2 (gdFileOpen camera-image2 "w"))
+ (gd2 (gdImageCreateTrueColor w2 h2)))
+ (gdImageCopyResampled gd2 gd 0 0 0 0 w2 h2 w h)
+ (gdImageWebp gd2 gdf2)
+ (gdImageDestroy gd)
+ (gdImageDestroy gd2)
+ (gdFileClose gdf)
+ (gdFileClose gdf2)
+ (let ((img (if (file-exists? camera-image2) (webp->img camera-image2) #f)))
+ (glgui-widget-set! gui background 'image (if img img default:background)))
+ (set! lastmodtime modtime)
+ ))))
+
+(main
+;; initialization
+ (lambda (w h)
+ (make-window 320 480)
+ (glgui-orientation-set! GUI_PORTRAIT)
+ (set! gui (make-glgui))
+ (let ((w (glgui-width-get))
+ (h (glgui-height-get)))
+ (set! background (glgui-pixmap gui 0 0 default:background w h))
+ (let* ((bw 150) (bh 50)
+ (bx (/ (- w bw) 2.))
+ (by (/ (- h bh) 2.)))
+ (glgui-button-string gui bx (+ by (* bh 2)) bw bh "Take picture" ascii_18.fnt
+ (lambda (un . used) (camera-start camera-image)))
+ ))
+ (if (file-exists? camera-image) (delete-file camera-image))
+ (if (file-exists? camera-image2) (delete-file camera-image2))
+ (let ((logdir (string-append (system-directory) "/log")))
+ (if (not (file-exists? logdir)) (create-directory logdir)))
+ )
+;; events
+ (lambda (t x y)
+ (autoload)
+ (if (= t EVENT_KEYPRESS) (begin
+ (if (= x EVENT_KEYESCAPE) (terminate))))
+ (glgui-event gui t x y))
+;; termination
+ (lambda () #t)
+;; suspend
+ (lambda () (glgui-suspend))
+;; resume
+ (lambda () (glgui-resume))
+)
+
+;; eof
diff --git a/apps/DemoCameraWebP/xml/file_paths.xml b/apps/DemoCameraWebP/xml/file_paths.xml
new file mode 100644
index 00000000..fa172d14
--- /dev/null
+++ b/apps/DemoCameraWebP/xml/file_paths.xml
@@ -0,0 +1,4 @@
+
+
+
+
\ No newline at end of file
diff --git a/libraries/libgd/LIB_DEPENDS b/libraries/libgd/LIB_DEPENDS
index 0675aab0..b9dba238 100644
--- a/libraries/libgd/LIB_DEPENDS
+++ b/libraries/libgd/LIB_DEPENDS
@@ -1 +1 @@
-libz libpng libjpeg libfreetype
+libz libpng libsharpyuv libwebp libjpeg libfreetype
diff --git a/libraries/libgd/make.sh b/libraries/libgd/make.sh
index a05ada7b..bfaff435 100755
--- a/libraries/libgd/make.sh
+++ b/libraries/libgd/make.sh
@@ -23,7 +23,7 @@ if [ "$SYS_PLATFORM" = "win32" ]; then
fi
fi
-package_configure $EXTRACONF --disable-shared --enable-static --with-png=$SYS_PREFIX --with-freetype=$SYS_PREFIX --with-jpeg=$SYS_PREFIX --without-avif --without-heif --without-tiff --without-webp --without-xpm --without-fontconfig --without-x
+package_configure $EXTRACONF --disable-shared --enable-static --with-png=$SYS_PREFIX --with-freetype=$SYS_PREFIX --with-jpeg=$SYS_PREFIX --without-avif --without-heif --without-tiff --with-webp=$SYS_PREFIX --without-xpm --without-fontconfig --without-x
cd src
package_make libgd.la
diff --git a/libraries/libsharpyuv/make.sh b/libraries/libsharpyuv/make.sh
new file mode 100755
index 00000000..0ef3e741
--- /dev/null
+++ b/libraries/libsharpyuv/make.sh
@@ -0,0 +1,23 @@
+PKGURL=https://github.com/webmproject/libwebp/archive/refs/tags/v1.6.0.tar.gz
+PKGHASH=6a5da51c23c8340e44a70421a5ef8bb1ae805ad2
+
+package_download $PKGURL $PKGHASH
+
+veval "./autogen.sh"
+asserterror $? "failed to generate configure script"
+
+rmifexists $SYS_PREFIX/include/webp
+
+if [ ! $SYS_PLATFORM = $SYS_HOSTPLATFORM ]; then
+ EXTRACONF=--host=$SYS_ARCH
+fi
+
+package_configure $EXTRACONF --disable-shared --enable-static --enable-dependency-tracking --enable-pic --disable-libwebpmux --disable-libwebpdemux --disable-gl --disable-gif --disable-png --disable-tiff --disable-jpeg --disable-sdl --disable-wic --disable-threading
+
+package_make
+
+package_make install
+
+package_cleanup
+
+#eof
diff --git a/libraries/libwebp/LIB_DEPENDS b/libraries/libwebp/LIB_DEPENDS
new file mode 100644
index 00000000..1f0952cd
--- /dev/null
+++ b/libraries/libwebp/LIB_DEPENDS
@@ -0,0 +1 @@
+libsharpyuv
diff --git a/libraries/libwebp/make.sh b/libraries/libwebp/make.sh
new file mode 100755
index 00000000..b81a5e72
--- /dev/null
+++ b/libraries/libwebp/make.sh
@@ -0,0 +1,2 @@
+
+# this is just a dummy, the libwebp is built alongside libsharpyuv
diff --git a/modules/gd/LIBRARIES b/modules/gd/LIBRARIES
index 796c6931..e9347c50 100644
--- a/modules/gd/LIBRARIES
+++ b/modules/gd/LIBRARIES
@@ -1 +1 @@
-libz!android libpng libfreetype libjpeg libgd
+libz!android libpng libsharpyuv libwebp libfreetype libjpeg libgd
diff --git a/modules/gd/gd.scm b/modules/gd/gd.scm
index 071c4851..511a97ae 100644
--- a/modules/gd/gd.scm
+++ b/modules/gd/gd.scm
@@ -170,11 +170,13 @@ end-of-c-declare
(gd-function gdImageCreateTrueColor (int int) (pointer void))
(gd-function gdImageCreateFromGif ((pointer void)) (pointer void))
(gd-function gdImageCreateFromPng ((pointer void)) (pointer void))
+(gd-function gdImageCreateFromWebp ((pointer void)) (pointer void))
(gd-function gdImageCreateFromJpeg ((pointer void)) (pointer void))
(gd-function gdImageCreateFromGd ((pointer void)) (pointer void))
(gd-function gdImageCreateFromGd2 ((pointer void)) (pointer void))
(gd-function gdImageGif ((pointer void) (pointer void)) void)
(gd-function gdImagePng ((pointer void) (pointer void)) void)
+(gd-function gdImageWebp ((pointer void) (pointer void)) void)
(gd-function gdImageJpeg ((pointer void) (pointer void) int) void)
(gd-function gdImageGd ((pointer void) (pointer void)) void)
(gd-function gdImageGd2 ((pointer void) (pointer void) int int) void)
diff --git a/modules/webp/LIBRARIES b/modules/webp/LIBRARIES
new file mode 100644
index 00000000..d60dce48
--- /dev/null
+++ b/modules/webp/LIBRARIES
@@ -0,0 +1 @@
+libwebp
diff --git a/modules/webp/webp.scm b/modules/webp/webp.scm
new file mode 100644
index 00000000..0db7d2fd
--- /dev/null
+++ b/modules/webp/webp.scm
@@ -0,0 +1,269 @@
+#|
+LambdaNative - a cross-platform Scheme framework
+Copyright (c) 2009-2014, University of British Columbia
+Copyright (c) 2026, Benson Muite
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or
+without modification, are permitted provided that the
+following conditions are met:
+
+* Redistributions of source code must retain the above
+copyright notice, this list of conditions and the following
+disclaimer.
+
+* Redistributions in binary form must reproduce the above
+copyright notice, this list of conditions and the following
+disclaimer in the documentation and/or other materials
+provided with the distribution.
+
+* Neither the name of the University of British Columbia nor
+the names of its contributors may be used to endorse or
+promote products derived from this software without specific
+prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+|#
+
+;; webp - wrapper for libwebp image library
+
+(define webp:debuglevel 0)
+(define (webp:log level . x)
+ (if (>= webp:debuglevel level) (apply log-system (append (list "webp: ") x))))
+
+(c-declare #<
+#include
+#include
+
+#include
+#include
+#include
+
+#define COLOR_GRAY 1
+#define COLOR_RGB 3
+#define COLOR_RGBA 4
+
+static int ln_webp_info(const char *fname, int infoarg)
+{
+
+ FILE *fd=0;
+ int res=-1;
+ uint8_t *file_data;
+ uint8_t *width;
+ uint8_t *height;
+ WebPBitstreamFeatures data_features;
+ size_t file_size;
+ fd = fopen(fname, "rb");
+ if (!fd) goto info_bail;
+ fseek(fd, 0, SEEK_END);
+ file_size = ftell(fd);
+ if (file_size == (size_t)-1) goto info_bail;
+ fseek(fd, 0, SEEK_SET);
+ // we allocate one extra byte for the \0 terminator
+ file_data = (uint8_t*)WebPMalloc(file_size + 1);
+ if (file_data == NULL) goto info_bail;
+ if (!(fread(file_data, file_size, 1, fd) == 1)) goto info_bail;
+ file_data[file_size] = '\0'; // convenient 0-terminator
+ if(WebPGetFeatures(file_data, file_size, &data_features) != VP8_STATUS_OK) goto info_bail;
+ switch (infoarg) {
+ case 1: res=(int) data_features.width; break;
+ case 2: res=(int) data_features.height; break;
+ case 3: res=(int) file_size; break;
+ case 4: res=(int) data_features.has_alpha; break;
+ case 5: res=(int) data_features.has_animation; break;
+ case 6: res=(int) data_features.format; break;
+ }
+info_bail:
+ if (file_data) WebPFree(file_data);
+ if (fd) fclose(fd);
+ return res;
+}
+
+static int ln_webp_from_u8vector(int w, int h, unsigned char *data, int datalen, const char *fname)
+{
+
+ FILE *fd=0;
+ int res=-1;
+ int color_types[] = { -1, COLOR_GRAY, -1, COLOR_RGB, COLOR_RGBA};
+ int stride = datalen/(w*h);
+ int color_type = (stride<5&&stride>0?color_types[stride]:-1);
+ if (color_type<0) goto writer_bail;
+ if (stride*w*h!=datalen) goto writer_bail;
+ uint8_t ** output = NULL;
+ uint8_t * data_webp = NULL;
+ data_webp = (uint8_t*)malloc(4*datalen*sizeof(uint8_t));
+ if (!data_webp) goto writer_bail;
+ size_t output_size=0;
+ fd = fopen (fname, "wb");
+ if (!fd) goto writer_bail;
+ switch (color_type) {
+ case COLOR_GRAY:
+ for(int i=0; i < datalen; i++) {
+ data_webp[3*i] = (uint8_t)data[i];
+ data_webp[3*i+1] = (uint8_t)data[i];
+ data_webp[3*i+2] = (uint8_t)data[i];
+ }
+ output_size=WebPEncodeLosslessRGB(data_webp, w, h, stride, output);
+ case COLOR_RGB:
+ for(int i=0; i < datalen; i++) {
+ data_webp[i] = (uint8_t)data[i];
+ }
+ output_size=WebPEncodeLosslessRGB(data_webp, w, h, stride, output);
+ break;
+ case COLOR_RGBA:
+ for(int i=0; i < datalen; i++) {
+ data_webp[i] = (uint8_t)data[i];
+ }
+ output_size=WebPEncodeLosslessRGBA(data_webp, w, h, stride, output);
+ break;
+ }
+ int out = fwrite(output,output_size,1,fd);
+ res = 0;
+ writer_bail:
+ if (data_webp) free(data_webp);
+ if (output) WebPFree(*output);
+ if (fd) fclose(fd);
+ return res;
+}
+
+static int ln_webp_to_u8vector(int w0, int h0, unsigned char *data, int file_size, const char *fname)
+{
+ FILE *fd=0;
+ int res=-1;
+ uint8_t *file_data = NULL;
+ uint8_t *buf = NULL;
+ size_t width;
+ size_t height;
+ fd = fopen(fname, "rb");
+ if (!fd) goto reader_bail;
+ // allocate an extra byte for the \0 terminator
+ file_data = (uint8_t*)WebPMalloc(file_size + 1);
+ if (file_data == NULL) goto reader_bail;
+ if (!(fread(file_data, file_size, 1, fd) == 1)) goto reader_bail;
+ file_data[file_size] = '\0'; // convenient 0-terminator
+ buf = WebPDecodeRGBA((const uint8_t*)file_data, (size_t)file_size, &width, &height);
+ for(int i=0; i < 4*w0*h0; i++) {
+ data[i] = (unsigned char) buf[i];
+ }
+ res=0;
+reader_bail:
+ if (file_data) WebPFree(file_data);
+ if (buf) WebPFree(buf);
+ if (fd) fclose(fd);
+ return res;
+}
+
+end-of-c-declare
+)
+
+(define (webp:info fname idx)
+ (webp:log 2 "webp:info " fname " " idx)
+ (let ((res ((c-lambda (char-string int) int "ln_webp_info") fname idx)))
+ (if (fx= res -1) (begin (log-error "webp:info " idx " failed on " fname) #f) res)))
+
+(define (webp-width fname) (webp:log 1 "webp-width " fname) (webp:info fname 1))
+(define (webp-height fname) (webp:log 1 "webp-height " fname) (webp:info fname 2))
+(define (webp-file_size fname) (webp:log 1 "webp-file_size " fname) (webp:info fname 3))
+(define (webp-has_alpha fname) (webp:log 1 "webp-has_alpha " fname) (webp:info fname 4))
+(define (webp-has_animation fname) (webp:log 1 "webp-has_animation " fname) (webp:info fname 5))
+(define (webp-compression_format fname) (webp:log 1 "webp-compression_format " fname) (webp:info fname 6))
+
+(define (u8vector->webp data fname w h)
+ (webp:log 1 "u8vector->webp " w " " h " [] " fname)
+ (fx= ((c-lambda (int int scheme-object int char-string) int
+ "___result=ln_webp_from_u8vector(___arg1,___arg2,___CAST(void*,___BODY_AS(___arg3,___tSUBTYPED)),___arg4,___arg5);")
+ w h data (u8vector-length data) fname) 0))
+
+(define (webp->u8vector fname . xargs)
+ (webp:log 1 "webp->u8vector " fname " " xargs)
+ (let* ((w (webp-width fname))
+ (h (webp-height fname))
+ (a (webp-has_animation fname))
+ (w0 (if (= (length xargs) 2) (car xargs) w))
+ (h0 (if (= (length xargs) 2) (cadr xargs) h))
+ (file_size (webp-file_size fname))
+ (data (if (and w h file_size (equal? a 0)) (make-u8vector (* w h 4) 0) #f)))
+ (if data (begin
+ (if (fx= ((c-lambda (int int scheme-object int char-string) int
+ "___result=ln_webp_to_u8vector(___arg1,___arg2,___CAST(void*,___BODY_AS(___arg3,___tSUBTYPED)),___arg4,___arg5);")
+ w0 h0 data file_size fname) 0) data #f))
+ (begin
+ (log-error "webp->u8vector failed on " fname) #f))))
+
+;; ------
+;; opengl related functions
+;; eval is used to delay resolving potentially unavailable calls
+
+(define (webp:webp->texture fname . xargs)
+ (webp:log 1 "webp->texture " fname " " xargs)
+ (let* ((w (webp-width fname))
+ (h (webp-height fname))
+ (a (webp-has_animation fname))
+ (w0 (if (= (length xargs) 2) (car xargs) w))
+ (h0 (if (= (length xargs) 2) (cadr xargs) h))
+ (data (webp->u8vector fname w0 h0)))
+ (if (and data (equal? a 0)) ((eval 'glCoreTextureCreate) w0 h0 data)
+ (begin (log-error "webp:webp->texture failed on " fname) #f))))
+
+(define (webp->img fname)
+ (webp:log 1 "webp->img " fname)
+ (let* ((w (webp-width fname))
+ (h (webp-height fname))
+ (a (webp-has_animation fname))
+ (w0 (fix (expt 2. (ceiling (/ (log w) (log 2.))))))
+ (h0 (fix (expt 2. (ceiling (/ (log h) (log 2.))))))
+ (t (webp:webp->texture fname)))
+ (if (and w h t (equal? a 0))
+ (list w h t 0. (- 1. (/ h h0 1.)) (/ w w0 1.) 1.)
+ (begin (log-error "webp->img failed on " fname) #f))))
+
+(define (webp:texture->webp t fname)
+ (webp:log 1 "texture->webp " t " " fname)
+ (let ((w ((eval 'glCoreTextureWidth) t))
+ (h ((eval 'glCoreTextureHeight) t))
+ (data ((eval 'glCoreTextureData) t)))
+ (u8vector->webp data fname w h)))
+
+(define (img->webp img fname)
+ (webp:texture->webp (caddr img) fname))
+
+(define (screenshot->webp fname)
+ (webp:log 1 "screenshot->webp " fname)
+ (let* ((w ((eval 'glgui-width-get)))
+ (h ((eval 'glgui-height-get)))
+ (data ((eval 'glCoreReadPixels) 0 0 w h)))
+ (u8vector->webp data fname w h)))
+
+;; ------
+;; unit test
+
+(unit-test "webp" "1000 random image encode-decode runs"
+ (lambda ()
+ (let* ((fname (string-append (system-directory) (system-pathseparator) "unittest.webp"))
+ (res (let loop ((n 1000))
+ (if (fx= n 0) #t (if
+ (let* ((w (+ 1 (random-integer 200)))
+ (h (+ 1 (random-integer 200)))
+ (data (random-u8vector (* 4 w h))))
+ (u8vector->webp data fname w h)
+ (not (and (= w (webp-width fname))
+ (= h (webp-height fname))
+ (equal? data (webp->u8vector fname))))) #f (loop (fx- n 1)))))))
+ (if (file-exists? fname) (delete-file fname))
+ res)))
+
+;; eof
|