1 2(********************************************************************) 3(* *) 4(* pv7.sd7 Picture viewer for several graphic formats. *) 5(* Copyright (C) 2021 Thomas Mertes *) 6(* *) 7(* This program is free software; you can redistribute it and/or *) 8(* modify it under the terms of the GNU General Public License as *) 9(* published by the Free Software Foundation; either version 2 of *) 10(* the License, or (at your option) any later version. *) 11(* *) 12(* This program is distributed in the hope that it will be useful, *) 13(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 14(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 15(* GNU General Public License for more details. *) 16(* *) 17(* You should have received a copy of the GNU General Public *) 18(* License along with this program; if not, write to the *) 19(* Free Software Foundation, Inc., 51 Franklin Street, *) 20(* Fifth Floor, Boston, MA 02110-1301, USA. *) 21(* *) 22(********************************************************************) 23 24 25$ include "seed7_05.s7i"; 26 include "imagefile.s7i"; 27 include "osfiles.s7i"; 28 include "time.s7i"; 29 include "duration.s7i"; 30 include "console.s7i"; 31 include "draw.s7i"; 32 include "stdfont24.s7i"; 33 34 35const proc: writeMessage (in string: message) is func 36 37 local 38 var text: screen is text.value; 39 begin 40 clear(curr_win, black); 41 rect((width(curr_win) - width(stdFont24, message)) div 2 - 50, 42 height(curr_win) div 2 - 50, 43 width(stdFont24, message) + 100, 100, white); 44 screen := openPixmapFontFile(curr_win); 45 color(screen, black, white); 46 setFont(screen, stdFont24); 47 setPosXY(screen, (width(curr_win) - width(stdFont24, message)) div 2, 48 (height(curr_win) + capHeight(stdFont24)) div 2); 49 write(screen, message); 50 end func; 51 52 53const func boolean: hasImageExtension (in var string: fileName) is func 54 result 55 var boolean: hasImageExtension is FALSE; 56 begin 57 fileName := lower(fileName); 58 hasImageExtension := endsWith(fileName, ".png") or 59 endsWith(fileName, ".gif") or 60 endsWith(fileName, ".jpeg") or 61 endsWith(fileName, ".jpg") or 62 endsWith(fileName, ".ppm") or 63 endsWith(fileName, ".bmp") or 64 endsWith(fileName, ".ico"); 65 end func; 66 67 68const proc: nextImageFile (in array string: fileList, inout integer: index) is func 69 begin 70 if index <= length(fileList) then 71 repeat 72 incr(index); 73 until index > length(fileList) or hasImageExtension(fileList[index]); 74 end if; 75 end func; 76 77 78const proc: previousImageFile (in array string: fileList, inout integer: index) is func 79 begin 80 if index >= 1 then 81 repeat 82 decr(index); 83 until index < 1 or hasImageExtension(fileList[index]); 84 end if; 85 end func; 86 87 88const proc: findFileWithName (in array string: fileList, in string: fileName, inout integer: index) is func 89 begin 90 index := 1; 91 while index <= length(fileList) and fileList[index] <> fileName do 92 incr(index); 93 end while; 94 if index > length(fileList) then 95 index := 0; 96 end if; 97 end func; 98 99 100const proc: displayImage (in PRIMITIVE_WINDOW: pixmap) is func 101 local 102 var integer: width is 0; 103 var integer: height is 0; 104 var integer: border is 0; 105 begin 106 if width(curr_win) * height(pixmap) >= width(pixmap) * height(curr_win) then 107 width := width(pixmap) * height(curr_win) div height(pixmap); 108 border := (width(curr_win) - width) div 2; 109 put(curr_win, border, 0, width, height(curr_win), pixmap); 110 rect(curr_win, 0, 0, border, height(curr_win), black); 111 rect(curr_win, border + width, 0, width(curr_win) - border - width, height(curr_win), black); 112 else 113 height := height(pixmap) * width(curr_win) div width(pixmap); 114 border := (height(curr_win) - height) div 2; 115 put(curr_win, 0, border, width(curr_win), height, pixmap); 116 rect(curr_win, 0, 0, width(curr_win), border, black); 117 rect(curr_win, 0, border + height, width(curr_win), height(curr_win) - border - height, black); 118 end if; 119 end func; 120 121 122const proc: main is func 123 local 124 var array string: fileList is 0 times ""; 125 var integer: index is 0; 126 var file: imageFile is STD_NULL; 127 var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value; 128 var boolean: commandPresent is FALSE; 129 var char: command is ' '; 130 begin 131 screen(1024, 688); 132 selectInput(curr_win, KEY_RESIZE, TRUE); 133 clear(curr_win, black); 134 flushGraphic; 135 KEYBOARD := GRAPH_KEYBOARD; 136 OUT := STD_CONSOLE; 137 fileList := readDir(getcwd); 138 if length(argv(PROGRAM)) >= 1 then 139 findFileWithName(fileList, argv(PROGRAM)[1], index); 140 if index = 0 or not hasImageExtension(fileList[index]) then 141 nextImageFile(fileList, index); 142 end if; 143 else 144 nextImageFile(fileList, index); 145 end if; 146 repeat 147 command := KEY_NONE; 148 if index < 1 then 149 setWindowName(curr_win, "Start"); 150 writeMessage("Start"); 151 elsif index > length(fileList) then 152 setWindowName(curr_win, "End"); 153 writeMessage("End"); 154 else 155 setWindowName(curr_win, fileList[index]); 156 imageFile := open(fileList[index], "r"); 157 if imageFile <> STD_NULL then 158 # writeln(fileList[index]); 159 pixmap := readImage(imageFile); 160 close(imageFile); 161 command := KEY_RESIZE; 162 repeat 163 if command = KEY_RESIZE then 164 if pixmap <> PRIMITIVE_WINDOW.value then 165 displayImage(pixmap); 166 else 167 writeMessage("Error reading " <& fileList[index]); 168 end if; 169 flushGraphic; 170 else 171 await(time(NOW) + 30000 . MICRO_SECONDS); 172 end if; 173 command := busy_getc(KEYBOARD); 174 until command <> KEY_NONE and command <> KEY_RESIZE; 175 commandPresent := TRUE; 176 else 177 writeMessage("Cannot open: " <& fileList[index]); 178 end if; 179 end if; 180 repeat 181 if not commandPresent then 182 command := getc(KEYBOARD); 183 end if; 184 if command = KEY_MOUSE1 or command = KEY_NL or command = KEY_TAB or command = KEY_RIGHT then 185 nextImageFile(fileList, index); 186 elsif command = KEY_MOUSE3 or command = KEY_BACKTAB or command = KEY_LEFT then 187 previousImageFile(fileList, index); 188 end if; 189 commandPresent := FALSE; 190 until not keypressed(KEYBOARD); 191 until lower(command) = 'q' or command = KEY_ESC; 192 end func; 193